C4/Search.pm

   1 package C4::Search;
   2
   3 # This file is part of Koha.
   4 #
   5 # Koha is free software; you can redistribute it and/or modify it under the
   6 # terms of the GNU General Public License as published by the Free Software
   7 # Foundation; either version 2 of the License, or (at your option) any later
   8 # version.
   9 #
  10 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  11 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  12 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License along with
  15 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  16 # Suite 330, Boston, MA  02111-1307 USA
  17
  18 use strict;
  19 #use warnings; FIXME - Bug 2505
  20 require Exporter;
  21 use C4::Context;
  22 use C4::Biblio;    # GetMarcFromKohaField, GetBiblioData
  23 use C4::Koha;      # getFacets
  24 use Lingua::Stem;
  25 use C4::Search::PazPar2;
  26 use XML::Simple;
  27 use C4::Dates qw(format_date);
  28 use C4::Members qw(GetHideLostItemsPreference);
  29 use C4::XSLT;
  30 use C4::Branch;
  31 use C4::Reserves;    # GetReserveStatus
  32 use C4::Debug;
  33 use C4::Charset;
  34 use YAML;
  35 use URI::Escape;
  36 use Business::ISBN;
  37 use MARC::Record;
  38 use MARC::Field;
  39 use Encode qw/decode_utf8/;
  40 use utf8;
  41 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
  42
  43 # set the version for version checking
  44 BEGIN {
  45     $VERSION = 3.07.00.049;
  46     $DEBUG = ($ENV{DEBUG}) ? 1 : 0;
  47 }
  48
  49 =head1 NAME
  50
  51 C4::Search - Functions for searching the Koha catalog.
  52
  53 =head1 SYNOPSIS
  54
  55 See opac/opac-search.pl or catalogue/search.pl for example of usage
  56
  57 =head1 DESCRIPTION
  58
  59 This module provides searching functions for Koha's bibliographic databases
  60
  61 =head1 FUNCTIONS
  62
  63 =cut
  64
  65 @ISA    = qw(Exporter);
  66 @EXPORT = qw(
  67   &FindDuplicate
  68   &SimpleSearch
  69   &searchResults
  70   &getRecords
  71   &buildQuery
  72   &AddSearchHistory
  73   &GetDistinctValues
  74   &enabled_staff_search_views
  75   &SimpleSearch
  76 );
  77
  78 # make all your functions, whether exported or not;
  79
  80 =head2 FindDuplicate
  81
  82 ($biblionumber,$biblionumber,$title) = FindDuplicate($record);
  83
  84 This function attempts to find duplicate records using a hard-coded, fairly simplistic algorithm
  85
  86 =cut
  87
  88 sub FindDuplicate {
  89     my ($record) = @_;
  90     my $dbh = C4::Context->dbh;
  91     my $result = TransformMarcToKoha( $dbh, $record, '' );
  92     my $sth;
  93     my $query;
  94     my $search;
  95     my $type;
  96     my ( $biblionumber, $title );
  97
  98     # search duplicate on ISBN, easy and fast..
  99     # ... normalize first
 100     if ( $result->{isbn} ) {
 101         $result->{isbn} =~ s/\(.*$//;
 102         $result->{isbn} =~ s/\s+$//;
 103         $query = "isbn:$result->{isbn}";
 104     }
 105     else {
 106         my $QParser;
 107         $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser'));
 108         my $titleindex;
 109         my $authorindex;
 110         my $op;
 111
 112         if ($QParser) {
 113             $titleindex = 'title|exact';
 114             $authorindex = 'author|exact';
 115             $op = '&&';
 116             $QParser->custom_data->{'QueryAutoTruncate'} = C4::Context->preference('QueryAutoTruncate');
 117         } else {
 118             $titleindex = 'ti,ext';
 119             $authorindex = 'au,ext';
 120             $op = 'and';
 121         }
 122
 123         $result->{title} =~ s /\\//g;
 124         $result->{title} =~ s /\"//g;
 125         $result->{title} =~ s /\(//g;
 126         $result->{title} =~ s /\)//g;
 127
 128         # FIXME: instead of removing operators, could just do
 129         # quotes around the value
 130         $result->{title} =~ s/(and|or|not)//g;
 131         $query = "$titleindex:\"$result->{title}\"";
 132         if   ( $result->{author} ) {
 133             $result->{author} =~ s /\\//g;
 134             $result->{author} =~ s /\"//g;
 135             $result->{author} =~ s /\(//g;
 136             $result->{author} =~ s /\)//g;
 137
 138             # remove valid operators
 139             $result->{author} =~ s/(and|or|not)//g;
 140             $query .= " $op $authorindex:\"$result->{author}\"";
 141         }
 142     }
 143
 144     my ( $error, $searchresults, undef ) = SimpleSearch($query); # FIXME :: hardcoded !
 145     my @results;
 146     if (!defined $error) {
 147         foreach my $possible_duplicate_record (@{$searchresults}) {
 148             my $marcrecord =
 149             MARC::Record->new_from_usmarc($possible_duplicate_record);
 150             my $result = TransformMarcToKoha( $dbh, $marcrecord, '' );
 151
 152             # FIXME :: why 2 $biblionumber ?
 153             if ($result) {
 154                 push @results, $result->{'biblionumber'};
 155                 push @results, $result->{'title'};
 156             }
 157         }
 158     }
 159     return @results;
 160 }
 161
 162 =head2 SimpleSearch
 163
 164 ( $error, $results, $total_hits ) = SimpleSearch( $query, $offset, $max_results, [@servers] );
 165
 166 This function provides a simple search API on the bibliographic catalog
 167
 168 =over 2
 169
 170 =item C<input arg:>
 171
 172     * $query can be a simple keyword or a complete CCL query
 173     * @servers is optional. Defaults to biblioserver as found in koha-conf.xml
 174     * $offset - If present, represents the number of records at the beggining to omit. Defaults to 0
 175     * $max_results - if present, determines the maximum number of records to fetch. undef is All. defaults to undef.
 176
 177
 178 =item C<Return:>
 179
 180     Returns an array consisting of three elements
 181     * $error is undefined unless an error is detected
 182     * $results is a reference to an array of records.
 183     * $total_hits is the number of hits that would have been returned with no limit
 184
 185     If an error is returned the two other return elements are undefined. If error itself is undefined
 186     the other two elements are always defined
 187
 188 =item C<usage in the script:>
 189
 190 =back
 191
 192 my ( $error, $marcresults, $total_hits ) = SimpleSearch($query);
 193
 194 if (defined $error) {
 195     $template->param(query_error => $error);
 196     warn "error: ".$error;
 197     output_html_with_http_headers $input, $cookie, $template->output;
 198     exit;
 199 }
 200
 201 my $hits = @{$marcresults};
 202 my @results;
 203
 204 for my $r ( @{$marcresults} ) {
 205     my $marcrecord = MARC::File::USMARC::decode($r);
 206     my $biblio = TransformMarcToKoha(C4::Context->dbh,$marcrecord,q{});
 207
 208     #build the iarray of hashs for the template.
 209     push @results, {
 210         title           => $biblio->{'title'},
 211         subtitle        => $biblio->{'subtitle'},
 212         biblionumber    => $biblio->{'biblionumber'},
 213         author          => $biblio->{'author'},
 214         publishercode   => $biblio->{'publishercode'},
 215         publicationyear => $biblio->{'publicationyear'},
 216         };
 217
 218 }
 219
 220 $template->param(result=>\@results);
 221
 222 =cut
 223
 224 sub SimpleSearch {
 225     my ( $query, $offset, $max_results, $servers )  = @_;
 226
 227     return ( 'No query entered', undef, undef ) unless $query;
 228     # FIXME hardcoded value. See catalog/search.pl & opac-search.pl too.
 229     my @servers = defined ( $servers ) ? @$servers : ( 'biblioserver' );
 230     my @zoom_queries;
 231     my @tmpresults;
 232     my @zconns;
 233     my $results = [];
 234     my $total_hits = 0;
 235
 236     my $QParser;
 237     $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser') && ! ($query =~ m/\w,\w|\w=\w/));
 238     if ($QParser) {
 239         $QParser->custom_data->{'QueryAutoTruncate'} = C4::Context->preference('QueryAutoTruncate');
 240     }
 241
 242     # Initialize & Search Zebra
 243     for ( my $i = 0 ; $i < @servers ; $i++ ) {
 244         eval {
 245             $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
 246             if ($QParser) {
 247                 $query =~ s/=/:/g;
 248                 $QParser->parse( $query );
 249                 $query = $QParser->target_syntax($servers[$i]);
 250                 $zoom_queries[$i] = new ZOOM::Query::PQF( $query, $zconns[$i]);
 251             } else {
 252                 $query =~ s/:/=/g;
 253                 $zoom_queries[$i] = new ZOOM::Query::CCL2RPN( $query, $zconns[$i]);
 254             }
 255             $tmpresults[$i] = $zconns[$i]->search( $zoom_queries[$i] );
 256
 257             # error handling
 258             my $error =
 259                 $zconns[$i]->errmsg() . " ("
 260               . $zconns[$i]->errcode() . ") "
 261               . $zconns[$i]->addinfo() . " "
 262               . $zconns[$i]->diagset();
 263
 264             return ( $error, undef, undef ) if $zconns[$i]->errcode();
 265         };
 266         if ($@) {
 267
 268             # caught a ZOOM::Exception
 269             my $error =
 270                 $@->message() . " ("
 271               . $@->code() . ") "
 272               . $@->addinfo() . " "
 273               . $@->diagset();
 274             warn $error." for query: $query";
 275             return ( $error, undef, undef );
 276         }
 277     }
 278
 279     _ZOOM_event_loop(
 280         \@zconns,
 281         \@tmpresults,
 282         sub {
 283             my ($i, $size) = @_;
 284             my $first_record = defined($offset) ? $offset + 1 : 1;
 285             my $hits = $tmpresults[ $i - 1 ]->size();
 286             $total_hits += $hits;
 287             my $last_record = $hits;
 288             if ( defined $max_results && $offset + $max_results < $hits ) {
 289                 $last_record = $offset + $max_results;
 290             }
 291
 292             for my $j ( $first_record .. $last_record ) {
 293                 my $record =
 294                   $tmpresults[ $i - 1 ]->record( $j - 1 )->raw()
 295                   ;    # 0 indexed
 296                 push @{$results}, $record;
 297             }
 298         }
 299     );
 300
 301     foreach my $zoom_query (@zoom_queries) {
 302         $zoom_query->destroy();
 303     }
 304
 305     return ( undef, $results, $total_hits );
 306 }
 307
 308 =head2 getRecords
 309
 310 ( undef, $results_hashref, \@facets_loop ) = getRecords (
 311
 312         $koha_query,       $simple_query, $sort_by_ref,    $servers_ref,
 313         $results_per_page, $offset,       $expanded_facet, $branches,$itemtypes,
 314         $query_type,       $scan
 315     );
 316
 317 The all singing, all dancing, multi-server, asynchronous, scanning,
 318 searching, record nabbing, facet-building
 319
 320 See verbse embedded documentation.
 321
 322 =cut
 323
 324 sub getRecords {
 325     my (
 326         $koha_query,       $simple_query, $sort_by_ref,    $servers_ref,
 327         $results_per_page, $offset,       $expanded_facet, $branches,
 328         $itemtypes,        $query_type,   $scan,           $opac
 329     ) = @_;
 330
 331     my @servers = @$servers_ref;
 332     my @sort_by = @$sort_by_ref;
 333
 334     # Initialize variables for the ZOOM connection and results object
 335     my $zconn;
 336     my @zconns;
 337     my @results;
 338     my $results_hashref = ();
 339
 340     # Initialize variables for the faceted results objects
 341     my $facets_counter = ();
 342     my $facets_info    = ();
 343     my $facets         = getFacets();
 344     my $facets_maxrecs = C4::Context->preference('maxRecordsForFacets')||20;
 345
 346     my @facets_loop;    # stores the ref to array of hashes for template facets loop
 347
 348     ### LOOP THROUGH THE SERVERS
 349     for ( my $i = 0 ; $i < @servers ; $i++ ) {
 350         $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
 351
 352 # perform the search, create the results objects
 353 # if this is a local search, use the $koha-query, if it's a federated one, use the federated-query
 354         my $query_to_use = ($servers[$i] =~ /biblioserver/) ? $koha_query : $simple_query;
 355
 356         #$query_to_use = $simple_query if $scan;
 357         warn $simple_query if ( $scan and $DEBUG );
 358
 359         # Check if we've got a query_type defined, if so, use it
 360         eval {
 361             if ($query_type) {
 362                 if ($query_type =~ /^ccl/) {
 363                     $query_to_use =~ s/\:/\=/g;    # change : to = last minute (FIXME)
 364                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::CCL2RPN($query_to_use, $zconns[$i]));
 365                 } elsif ($query_type =~ /^cql/) {
 366                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::CQL($query_to_use, $zconns[$i]));
 367                 } elsif ($query_type =~ /^pqf/) {
 368                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::PQF($query_to_use, $zconns[$i]));
 369                 } else {
 370                     warn "Unknown query_type '$query_type'.  Results undetermined.";
 371                 }
 372             } elsif ($scan) {
 373                     $results[$i] = $zconns[$i]->scan(  new ZOOM::Query::CCL2RPN($query_to_use, $zconns[$i]));
 374             } else {
 375                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::CCL2RPN($query_to_use, $zconns[$i]));
 376             }
 377         };
 378         if ($@) {
 379             warn "WARNING: query problem with $query_to_use " . $@;
 380         }
 381
 382         # Concatenate the sort_by limits and pass them to the results object
 383         # Note: sort will override rank
 384         my $sort_by;
 385         foreach my $sort (@sort_by) {
 386             if ( $sort eq "author_az" || $sort eq "author_asc" ) {
 387                 $sort_by .= "1=1003 <i ";
 388             }
 389             elsif ( $sort eq "author_za" || $sort eq "author_dsc" ) {
 390                 $sort_by .= "1=1003 >i ";
 391             }
 392             elsif ( $sort eq "popularity_asc" ) {
 393                 $sort_by .= "1=9003 <i ";
 394             }
 395             elsif ( $sort eq "popularity_dsc" ) {
 396                 $sort_by .= "1=9003 >i ";
 397             }
 398             elsif ( $sort eq "call_number_asc" ) {
 399                 $sort_by .= "1=8007  <i ";
 400             }
 401             elsif ( $sort eq "call_number_dsc" ) {
 402                 $sort_by .= "1=8007 >i ";
 403             }
 404             elsif ( $sort eq "pubdate_asc" ) {
 405                 $sort_by .= "1=31 <i ";
 406             }
 407             elsif ( $sort eq "pubdate_dsc" ) {
 408                 $sort_by .= "1=31 >i ";
 409             }
 410             elsif ( $sort eq "acqdate_asc" ) {
 411                 $sort_by .= "1=32 <i ";
 412             }
 413             elsif ( $sort eq "acqdate_dsc" ) {
 414                 $sort_by .= "1=32 >i ";
 415             }
 416             elsif ( $sort eq "title_az" || $sort eq "title_asc" ) {
 417                 $sort_by .= "1=4 <i ";
 418             }
 419             elsif ( $sort eq "title_za" || $sort eq "title_dsc" ) {
 420                 $sort_by .= "1=4 >i ";
 421             }
 422             else {
 423                 warn "Ignoring unrecognized sort '$sort' requested" if $sort_by;
 424             }
 425         }
 426         if ($sort_by && !$scan) {
 427             if ( $results[$i]->sort( "yaz", $sort_by ) < 0 ) {
 428                 warn "WARNING sort $sort_by failed";
 429             }
 430         }
 431     }    # finished looping through servers
 432
 433     # The big moment: asynchronously retrieve results from all servers
 434         _ZOOM_event_loop(
 435             \@zconns,
 436             \@results,
 437             sub {
 438                 my ( $i, $size ) = @_;
 439                 my $results_hash;
 440
 441                 # loop through the results
 442                 $results_hash->{'hits'} = $size;
 443                 my $times;
 444                 if ( $offset + $results_per_page <= $size ) {
 445                     $times = $offset + $results_per_page;
 446                 }
 447                 else {
 448                     $times = $size;
 449                 }
 450                 for ( my $j = $offset ; $j < $times ; $j++ ) {
 451                     my $records_hash;
 452                     my $record;
 453
 454                     ## Check if it's an index scan
 455                     if ($scan) {
 456                         my ( $term, $occ ) = $results[ $i - 1 ]->term($j);
 457
 458                  # here we create a minimal MARC record and hand it off to the
 459                  # template just like a normal result ... perhaps not ideal, but
 460                  # it works for now
 461                         my $tmprecord = MARC::Record->new();
 462                         $tmprecord->encoding('UTF-8');
 463                         my $tmptitle;
 464                         my $tmpauthor;
 465
 466                 # the minimal record in author/title (depending on MARC flavour)
 467                         if ( C4::Context->preference("marcflavour") eq
 468                             "UNIMARC" )
 469                         {
 470                             $tmptitle = MARC::Field->new(
 471                                 '200', ' ', ' ',
 472                                 a => $term,
 473                                 f => $occ
 474                             );
 475                             $tmprecord->append_fields($tmptitle);
 476                         }
 477                         else {
 478                             $tmptitle =
 479                               MARC::Field->new( '245', ' ', ' ', a => $term, );
 480                             $tmpauthor =
 481                               MARC::Field->new( '100', ' ', ' ', a => $occ, );
 482                             $tmprecord->append_fields($tmptitle);
 483                             $tmprecord->append_fields($tmpauthor);
 484                         }
 485                         $results_hash->{'RECORDS'}[$j] =
 486                           $tmprecord->as_usmarc();
 487                     }
 488
 489                     # not an index scan
 490                     else {
 491                         $record = $results[ $i - 1 ]->record($j)->raw();
 492
 493                         # warn "RECORD $j:".$record;
 494                         $results_hash->{'RECORDS'}[$j] = $record;
 495                     }
 496
 497                 }
 498                 $results_hashref->{ $servers[ $i - 1 ] } = $results_hash;
 499
 500 # Fill the facets while we're looping, but only for the biblioserver and not for a scan
 501                 if ( !$scan && $servers[ $i - 1 ] =~ /biblioserver/ ) {
 502
 503                     my $jmax =
 504                       $size > $facets_maxrecs ? $facets_maxrecs : $size;
 505                     for my $facet (@$facets) {
 506                         for ( my $j = 0 ; $j < $jmax ; $j++ ) {
 507                             my $render_record = decode_utf8(
 508                               $results[ $i - 1 ]->record($j)->render());
 509                             my @used_datas = ();
 510                             foreach my $tag ( @{ $facet->{tags} } ) {
 511
 512                                 # avoid first line
 513                                 my $tag_num = substr( $tag, 0, 3 );
 514                                 my $letters = substr( $tag, 3 );
 515                                 my $field_pattern =
 516                                   '\n' . $tag_num . ' ([^z][^\n]+)';
 517                                 $field_pattern = '\n' . $tag_num . ' ([^\n]+)'
 518                                   if ( int($tag_num) < 10 );
 519                                 my @field_tokens =
 520                                   ( $render_record =~ /$field_pattern/g );
 521                                 foreach my $field_token (@field_tokens) {
 522                                     my @subf = ( $field_token =~
 523                                           /\$([a-zA-Z0-9]) ([^\$]+)/g );
 524                                     my @values;
 525                                     for ( my $i = 0 ; $i < @subf ; $i += 2 ) {
 526                                         if ( $letters =~ $subf[$i] ) {
 527                                             my $value = $subf[ $i + 1 ];
 528                                             $value =~ s/^ *//;
 529                                             $value =~ s/ *$//;
 530                                             push @values, $value;
 531                                         }
 532                                     }
 533                                     my $data = join( $facet->{sep}, @values );
 534                                     unless ( $data ~~ @used_datas ) {
 535                                         $facets_counter->{ $facet->{idx} }
 536                                           ->{$data}++;
 537                                         push @used_datas, $data;
 538                                     }
 539                                 }    # fields
 540                             }    # field codes
 541                         }    # records
 542                         $facets_info->{ $facet->{idx} }->{label_value} =
 543                           $facet->{label};
 544                         $facets_info->{ $facet->{idx} }->{expanded} =
 545                           $facet->{expanded};
 546                     }    # facets
 547                 }
 548
 549                 # warn "connection ", $i-1, ": $size hits";
 550                 # warn $results[$i-1]->record(0)->render() if $size > 0;
 551
 552                 # BUILD FACETS
 553                 if ( $servers[ $i - 1 ] =~ /biblioserver/ ) {
 554                     for my $link_value (
 555                         sort { $facets_counter->{$b} <=> $facets_counter->{$a} }
 556                         keys %$facets_counter
 557                       )
 558                     {
 559                         my $expandable;
 560                         my $number_of_facets;
 561                         my @this_facets_array;
 562                         for my $one_facet (
 563                             sort {
 564                                 $facets_counter->{$link_value}
 565                                   ->{$b} <=> $facets_counter->{$link_value}
 566                                   ->{$a}
 567                             } keys %{ $facets_counter->{$link_value} }
 568                           )
 569                         {
 570                             $number_of_facets++;
 571                             if (   ( $number_of_facets <= 5 )
 572                                 || ( $expanded_facet eq $link_value )
 573                                 || ( $facets_info->{$link_value}->{'expanded'} )
 574                               )
 575                             {
 576
 577 # Sanitize the link value : parenthesis, question and exclamation mark will cause errors with CCL
 578                                 my $facet_link_value = $one_facet;
 579                                 $facet_link_value =~ s/[()!?¡¿؟]/ /g;
 580
 581                                 # fix the length that will display in the label,
 582                                 my $facet_label_value = $one_facet;
 583                                 my $facet_max_length  = C4::Context->preference(
 584                                     'FacetLabelTruncationLength')
 585                                   || 20;
 586                                 $facet_label_value =
 587                                   substr( $one_facet, 0, $facet_max_length )
 588                                   . "..."
 589                                   if length($facet_label_value) >
 590                                       $facet_max_length;
 591
 592                             # if it's a branch, label by the name, not the code,
 593                                 if ( $link_value =~ /branch/ ) {
 594                                     if (   defined $branches
 595                                         && ref($branches) eq "HASH"
 596                                         && defined $branches->{$one_facet}
 597                                         && ref( $branches->{$one_facet} ) eq
 598                                         "HASH" )
 599                                     {
 600                                         $facet_label_value =
 601                                           $branches->{$one_facet}
 602                                           ->{'branchname'};
 603                                     }
 604                                     else {
 605                                         $facet_label_value = "*";
 606                                     }
 607                                 }
 608
 609                           # if it's a itemtype, label by the name, not the code,
 610                                 if ( $link_value =~ /itype/ ) {
 611                                     if (   defined $itemtypes
 612                                         && ref($itemtypes) eq "HASH"
 613                                         && defined $itemtypes->{$one_facet}
 614                                         && ref( $itemtypes->{$one_facet} ) eq
 615                                         "HASH" )
 616                                     {
 617                                         $facet_label_value =
 618                                           $itemtypes->{$one_facet}
 619                                           ->{'description'};
 620                                     }
 621                                 }
 622
 623                # also, if it's a location code, use the name instead of the code
 624                                 if ( $link_value =~ /location/ ) {
 625                                     $facet_label_value =
 626                                       GetKohaAuthorisedValueLib( 'LOC',
 627                                         $one_facet, $opac );
 628                                 }
 629
 630                 # but we're down with the whole label being in the link's title.
 631                                 push @this_facets_array,
 632                                   {
 633                                     facet_count =>
 634                                       $facets_counter->{$link_value}
 635                                       ->{$one_facet},
 636                                     facet_label_value => $facet_label_value,
 637                                     facet_title_value => $one_facet,
 638                                     facet_link_value  => $facet_link_value,
 639                                     type_link_value   => $link_value,
 640                                   }
 641                                   if ($facet_label_value);
 642                             }
 643                         }
 644
 645                         # handle expanded option
 646                         unless ( $facets_info->{$link_value}->{'expanded'} ) {
 647                             $expandable = 1
 648                               if ( ( $number_of_facets > 5 )
 649                                 && ( $expanded_facet ne $link_value ) );
 650                         }
 651                         push @facets_loop,
 652                           {
 653                             type_link_value => $link_value,
 654                             type_id         => $link_value . "_id",
 655                             "type_label_"
 656                               . $facets_info->{$link_value}->{'label_value'} =>
 657                               1,
 658                             facets     => \@this_facets_array,
 659                             expandable => $expandable,
 660                             expand     => $link_value,
 661                           }
 662                           unless (
 663                             (
 664                                 $facets_info->{$link_value}->{'label_value'} =~
 665                                 /Libraries/
 666                             )
 667                             and ( C4::Context->preference('singleBranchMode') )
 668                           );
 669                     }
 670                 }
 671             }
 672         );
 673     return ( undef, $results_hashref, \@facets_loop );
 674 }
 675
 676 sub pazGetRecords {
 677     my (
 678         $koha_query,       $simple_query, $sort_by_ref,    $servers_ref,
 679         $results_per_page, $offset,       $expanded_facet, $branches,
 680         $query_type,       $scan
 681     ) = @_;
 682
 683     my $paz = C4::Search::PazPar2->new(C4::Context->config('pazpar2url'));
 684     $paz->init();
 685     $paz->search($simple_query);
 686     sleep 1;   # FIXME: WHY?
 687
 688     # do results
 689     my $results_hashref = {};
 690     my $stats = XMLin($paz->stat);
 691     my $results = XMLin($paz->show($offset, $results_per_page, 'work-title:1'), forcearray => 1);
 692
 693     # for a grouped search result, the number of hits
 694     # is the number of groups returned; 'bib_hits' will have
 695     # the total number of bibs.
 696     $results_hashref->{'biblioserver'}->{'hits'} = $results->{'merged'}->[0];
 697     $results_hashref->{'biblioserver'}->{'bib_hits'} = $stats->{'hits'};
 698
 699     HIT: foreach my $hit (@{ $results->{'hit'} }) {
 700         my $recid = $hit->{recid}->[0];
 701
 702         my $work_title = $hit->{'md-work-title'}->[0];
 703         my $work_author;
 704         if (exists $hit->{'md-work-author'}) {
 705             $work_author = $hit->{'md-work-author'}->[0];
 706         }
 707         my $group_label = (defined $work_author) ? "$work_title / $work_author" : $work_title;
 708
 709         my $result_group = {};
 710         $result_group->{'group_label'} = $group_label;
 711         $result_group->{'group_merge_key'} = $recid;
 712
 713         my $count = 1;
 714         if (exists $hit->{count}) {
 715             $count = $hit->{count}->[0];
 716         }
 717         $result_group->{'group_count'} = $count;
 718
 719         for (my $i = 0; $i < $count; $i++) {
 720             # FIXME -- may need to worry about diacritics here
 721             my $rec = $paz->record($recid, $i);
 722             push @{ $result_group->{'RECORDS'} }, $rec;
 723         }
 724
 725         push @{ $results_hashref->{'biblioserver'}->{'GROUPS'} }, $result_group;
 726     }
 727
 728     # pass through facets
 729     my $termlist_xml = $paz->termlist('author,subject');
 730     my $terms = XMLin($termlist_xml, forcearray => 1);
 731     my @facets_loop = ();
 732     #die Dumper($results);
 733 #    foreach my $list (sort keys %{ $terms->{'list'} }) {
 734 #        my @facets = ();
 735 #        foreach my $facet (sort @{ $terms->{'list'}->{$list}->{'term'} } ) {
 736 #            push @facets, {
 737 #                facet_label_value => $facet->{'name'}->[0],
 738 #            };
 739 #        }
 740 #        push @facets_loop, ( {
 741 #            type_label => $list,
 742 #            facets => \@facets,
 743 #        } );
 744 #    }
 745
 746     return ( undef, $results_hashref, \@facets_loop );
 747 }
 748
 749 # STOPWORDS
 750 sub _remove_stopwords {
 751     my ( $operand, $index ) = @_;
 752     my @stopwords_removed;
 753
 754     # phrase and exact-qualified indexes shouldn't have stopwords removed
 755     if ( $index !~ m/,(phr|ext)/ ) {
 756
 757 # remove stopwords from operand : parse all stopwords & remove them (case insensitive)
 758 #       we use IsAlpha unicode definition, to deal correctly with diacritics.
 759 #       otherwise, a French word like "leçon" woudl be split into "le" "çon", "le"
 760 #       is a stopword, we'd get "çon" and wouldn't find anything...
 761 #
 762                 foreach ( keys %{ C4::Context->stopwords } ) {
 763                         next if ( $_ =~ /(and|or|not)/ );    # don't remove operators
 764                         if ( my ($matched) = ($operand =~
 765                                 /([^\X\p{isAlnum}]\Q$_\E[^\X\p{isAlnum}]|[^\X\p{isAlnum}]\Q$_\E$|^\Q$_\E[^\X\p{isAlnum}])/gi))
 766                         {
 767                                 $operand =~ s/\Q$matched\E/ /gi;
 768                                 push @stopwords_removed, $_;
 769                         }
 770                 }
 771         }
 772     return ( $operand, \@stopwords_removed );
 773 }
 774
 775 # TRUNCATION
 776 sub _detect_truncation {
 777     my ( $operand, $index ) = @_;
 778     my ( @nontruncated, @righttruncated, @lefttruncated, @rightlefttruncated,
 779         @regexpr );
 780     $operand =~ s/^ //g;
 781     my @wordlist = split( /\s/, $operand );
 782     foreach my $word (@wordlist) {
 783         if ( $word =~ s/^\*([^\*]+)\*$/$1/ ) {
 784             push @rightlefttruncated, $word;
 785         }
 786         elsif ( $word =~ s/^\*([^\*]+)$/$1/ ) {
 787             push @lefttruncated, $word;
 788         }
 789         elsif ( $word =~ s/^([^\*]+)\*$/$1/ ) {
 790             push @righttruncated, $word;
 791         }
 792         elsif ( index( $word, "*" ) < 0 ) {
 793             push @nontruncated, $word;
 794         }
 795         else {
 796             push @regexpr, $word;
 797         }
 798     }
 799     return (
 800         \@nontruncated,       \@righttruncated, \@lefttruncated,
 801         \@rightlefttruncated, \@regexpr
 802     );
 803 }
 804
 805 # STEMMING
 806 sub _build_stemmed_operand {
 807     my ($operand,$lang) = @_;
 808     require Lingua::Stem::Snowball ;
 809     my $stemmed_operand=q{};
 810
 811     # If operand contains a digit, it is almost certainly an identifier, and should
 812     # not be stemmed.  This is particularly relevant for ISBNs and ISSNs, which
 813     # can contain the letter "X" - for example, _build_stemmend_operand would reduce
 814     # "014100018X" to "x ", which for a MARC21 database would bring up irrelevant
 815     # results (e.g., "23 x 29 cm." from the 300$c).  Bug 2098.
 816     return $operand if $operand =~ /\d/;
 817
 818 # FIXME: the locale should be set based on the user's language and/or search choice
 819     #warn "$lang";
 820     # Make sure we only use the first two letters from the language code
 821     $lang = lc(substr($lang, 0, 2));
 822     # The language codes for the two variants of Norwegian will now be "nb" and "nn",
 823     # none of which Lingua::Stem::Snowball can use, so we need to "translate" them
 824     if ($lang eq 'nb' || $lang eq 'nn') {
 825       $lang = 'no';
 826     }
 827     my $stemmer = Lingua::Stem::Snowball->new( lang => $lang,
 828                                                encoding => "UTF-8" );
 829
 830     my @words = split( / /, $operand );
 831     my @stems = $stemmer->stem(\@words);
 832     for my $stem (@stems) {
 833         $stemmed_operand .= "$stem";
 834         $stemmed_operand .= "?"
 835           unless ( $stem =~ /(and$|or$|not$)/ ) || ( length($stem) < 3 );
 836         $stemmed_operand .= " ";
 837     }
 838     warn "STEMMED OPERAND: $stemmed_operand" if $DEBUG;
 839     return $stemmed_operand;
 840 }
 841
 842 # FIELD WEIGHTING
 843 sub _build_weighted_query {
 844
 845 # FIELD WEIGHTING - This is largely experimental stuff. What I'm committing works
 846 # pretty well but could work much better if we had a smarter query parser
 847     my ( $operand, $stemmed_operand, $index ) = @_;
 848     my $stemming      = C4::Context->preference("QueryStemming")     || 0;
 849     my $weight_fields = C4::Context->preference("QueryWeightFields") || 0;
 850     my $fuzzy_enabled = C4::Context->preference("QueryFuzzy")        || 0;
 851     $operand =~ s/"/ /g;    # Bug 7518: searches with quotation marks don't work
 852
 853     my $weighted_query .= "(rk=(";    # Specifies that we're applying rank
 854
 855     # Keyword, or, no index specified
 856     if ( ( $index eq 'kw' ) || ( !$index ) ) {
 857         $weighted_query .=
 858           "Title-cover,ext,r1=\"$operand\"";    # exact title-cover
 859         $weighted_query .= " or ti,ext,r2=\"$operand\"";    # exact title
 860         $weighted_query .= " or Title-cover,phr,r3=\"$operand\"";    # phrase title
 861           #$weighted_query .= " or any,ext,r4=$operand";               # exact any
 862           #$weighted_query .=" or kw,wrdl,r5=\"$operand\"";            # word list any
 863         $weighted_query .= " or wrdl,fuzzy,r8=\"$operand\""
 864           if $fuzzy_enabled;    # add fuzzy, word list
 865         $weighted_query .= " or wrdl,right-Truncation,r9=\"$stemmed_operand\""
 866           if ( $stemming and $stemmed_operand )
 867           ;                     # add stemming, right truncation
 868         $weighted_query .= " or wrdl,r9=\"$operand\"";
 869
 870         # embedded sorting: 0 a-z; 1 z-a
 871         # $weighted_query .= ") or (sort1,aut=1";
 872     }
 873
 874     # Barcode searches should skip this process
 875     elsif ( $index eq 'bc' ) {
 876         $weighted_query .= "bc=\"$operand\"";
 877     }
 878
 879     # Authority-number searches should skip this process
 880     elsif ( $index eq 'an' ) {
 881         $weighted_query .= "an=\"$operand\"";
 882     }
 883
 884     # If the index already has more than one qualifier, wrap the operand
 885     # in quotes and pass it back (assumption is that the user knows what they
 886     # are doing and won't appreciate us mucking up their query
 887     elsif ( $index =~ ',' ) {
 888         $weighted_query .= " $index=\"$operand\"";
 889     }
 890
 891     #TODO: build better cases based on specific search indexes
 892     else {
 893         $weighted_query .= " $index,ext,r1=\"$operand\"";    # exact index
 894           #$weighted_query .= " or (title-sort-az=0 or $index,startswithnt,st-word,r3=$operand #)";
 895         $weighted_query .= " or $index,phr,r3=\"$operand\"";    # phrase index
 896         $weighted_query .= " or $index,wrdl,r6=\"$operand\"";    # word list index
 897         $weighted_query .= " or $index,wrdl,fuzzy,r8=\"$operand\""
 898           if $fuzzy_enabled;    # add fuzzy, word list
 899         $weighted_query .= " or $index,wrdl,rt,r9=\"$stemmed_operand\""
 900           if ( $stemming and $stemmed_operand );    # add stemming, right truncation
 901     }
 902
 903     $weighted_query .= "))";                       # close rank specification
 904     return $weighted_query;
 905 }
 906
 907 =head2 getIndexes
 908
 909 Return an array with available indexes.
 910
 911 =cut
 912
 913 sub getIndexes{
 914     my @indexes = (
 915                     # biblio indexes
 916                     'ab',
 917                     'Abstract',
 918                     'acqdate',
 919                     'allrecords',
 920                     'an',
 921                     'Any',
 922                     'at',
 923                     'au',
 924                     'aub',
 925                     'aud',
 926                     'audience',
 927                     'auo',
 928                     'aut',
 929                     'Author',
 930                     'Author-in-order ',
 931                     'Author-personal-bibliography',
 932                     'Authority-Number',
 933                     'authtype',
 934                     'bc',
 935                     'Bib-level',
 936                     'biblionumber',
 937                     'bio',
 938                     'biography',
 939                     'callnum',
 940                     'cfn',
 941                     'Chronological-subdivision',
 942                     'cn-bib-source',
 943                     'cn-bib-sort',
 944                     'cn-class',
 945                     'cn-item',
 946                     'cn-prefix',
 947                     'cn-suffix',
 948                     'cpn',
 949                     'Code-institution',
 950                     'Conference-name',
 951                     'Conference-name-heading',
 952                     'Conference-name-see',
 953                     'Conference-name-seealso',
 954                     'Content-type',
 955                     'Control-number',
 956                     'copydate',
 957                     'Corporate-name',
 958                     'Corporate-name-heading',
 959                     'Corporate-name-see',
 960                     'Corporate-name-seealso',
 961                     'ctype',
 962                     'date-entered-on-file',
 963                     'Date-of-acquisition',
 964                     'Date-of-publication',
 965                     'Dewey-classification',
 966                     'EAN',
 967                     'extent',
 968                     'fic',
 969                     'fiction',
 970                     'Form-subdivision',
 971                     'format',
 972                     'Geographic-subdivision',
 973                     'he',
 974                     'Heading',
 975                     'Heading-use-main-or-added-entry',
 976                     'Heading-use-series-added-entry ',
 977                     'Heading-use-subject-added-entry',
 978                     'Host-item',
 979                     'id-other',
 980                     'Illustration-code',
 981                     'ISBN',
 982                     'isbn',
 983                     'ISSN',
 984                     'issn',
 985                     'itemtype',
 986                     'kw',
 987                     'Koha-Auth-Number',
 988                     'l-format',
 989                     'language',
 990                     'lc-card',
 991                     'LC-card-number',
 992                     'lcn',
 993                     'llength',
 994                     'ln',
 995                     'Local-classification',
 996                     'Local-number',
 997                     'Match-heading',
 998                     'Match-heading-see-from',
 999                     'Material-type',
1000                     'mc-itemtype',
1001                     'mc-rtype',
1002                     'mus',
1003                     'name',
1004                     'Music-number',
1005                     'Name-geographic',
1006                     'Name-geographic-heading',
1007                     'Name-geographic-see',
1008                     'Name-geographic-seealso',
1009                     'nb',
1010                     'Note',
1011                     'notes',
1012                     'ns',
1013                     'nt',
1014                     'pb',
1015                     'Personal-name',
1016                     'Personal-name-heading',
1017                     'Personal-name-see',
1018                     'Personal-name-seealso',
1019                     'pl',
1020                     'Place-publication',
1021                     'pn',
1022                     'popularity',
1023                     'pubdate',
1024                     'Publisher',
1025                     'Record-control-number',
1026                     'rcn',
1027                     'Record-type',
1028                     'rtype',
1029                     'se',
1030                     'See',
1031                     'See-also',
1032                     'sn',
1033                     'Stock-number',
1034                     'su',
1035                     'Subject',
1036                     'Subject-heading-thesaurus',
1037                     'Subject-name-personal',
1038                     'Subject-subdivision',
1039                     'Summary',
1040                     'Suppress',
1041                     'su-geo',
1042                     'su-na',
1043                     'su-to',
1044                     'su-ut',
1045                     'ut',
1046                     'UPC',
1047                     'Term-genre-form',
1048                     'Term-genre-form-heading',
1049                     'Term-genre-form-see',
1050                     'Term-genre-form-seealso',
1051                     'ti',
1052                     'Title',
1053                     'Title-cover',
1054                     'Title-series',
1055                     'Title-host',
1056                     'Title-uniform',
1057                     'Title-uniform-heading',
1058                     'Title-uniform-see',
1059                     'Title-uniform-seealso',
1060                     'totalissues',
1061                     'yr',
1062
1063                     # items indexes
1064                     'acqsource',
1065                     'barcode',
1066                     'bc',
1067                     'branch',
1068                     'ccode',
1069                     'classification-source',
1070                     'cn-sort',
1071                     'coded-location-qualifier',
1072                     'copynumber',
1073                     'damaged',
1074                     'datelastborrowed',
1075                     'datelastseen',
1076                     'holdingbranch',
1077                     'homebranch',
1078                     'issues',
1079                     'item',
1080                     'itemnumber',
1081                     'itype',
1082                     'Local-classification',
1083                     'location',
1084                     'lost',
1085                     'materials-specified',
1086                     'mc-ccode',
1087                     'mc-itype',
1088                     'mc-loc',
1089                     'notforloan',
1090                     'onloan',
1091                     'price',
1092                     'renewals',
1093                     'replacementprice',
1094                     'replacementpricedate',
1095                     'reserves',
1096                     'restricted',
1097                     'stack',
1098                     'stocknumber',
1099                     'inv',
1100                     'uri',
1101                     'withdrawn',
1102
1103                     # subject related
1104                   );
1105
1106     return \@indexes;
1107 }
1108
1109 =head2 _handle_exploding_index
1110
1111     my $query = _handle_exploding_index($index, $term)
1112
1113 Callback routine to generate the search for "exploding" indexes (i.e.
1114 those indexes which are turned into multiple or-connected searches based
1115 on authority data).
1116
1117 =cut
1118
1119 sub _handle_exploding_index {
1120     my ($QParser, $filter, $params, $negate, $server) = @_;
1121     my $index = $filter;
1122     my $term = join(' ', @$params);
1123
1124     return unless ($index =~ m/(su-br|su-na|su-rl)/ && $term);
1125
1126     my $marcflavour = C4::Context->preference('marcflavour');
1127
1128     my $codesubfield = $marcflavour eq 'UNIMARC' ? '5' : 'w';
1129     my $wantedcodes = '';
1130     my @subqueries = ( "\@attr 1=Subject \@attr 4=1 \"$term\"");
1131     my ($error, $results, $total_hits) = SimpleSearch( "he:$term", undef, undef, [ "authorityserver" ] );
1132     foreach my $auth (@$results) {
1133         my $record = MARC::Record->new_from_usmarc($auth);
1134         my @references = $record->field('5..');
1135         if (@references) {
1136             if ($index eq 'su-br') {
1137                 $wantedcodes = 'g';
1138             } elsif ($index eq 'su-na') {
1139                 $wantedcodes = 'h';
1140             } elsif ($index eq 'su-rl') {
1141                 $wantedcodes = '';
1142             }
1143             foreach my $reference (@references) {
1144                 my $codes = $reference->subfield($codesubfield);
1145                 push @subqueries, '@attr 1=Subject @attr 4=1 "' . $reference->as_string('abcdefghijlmnopqrstuvxyz') . '"' if (($codes && $codes eq $wantedcodes) || !$wantedcodes);
1146             }
1147         }
1148     }
1149     my $query = ' @or ' x (scalar(@subqueries) - 1) . join(' ', @subqueries);
1150     return $query;
1151 }
1152
1153 =head2 parseQuery
1154
1155     ( $operators, $operands, $indexes, $limits,
1156       $sort_by, $scan, $lang ) =
1157             buildQuery ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang);
1158
1159 Shim function to ease the transition from buildQuery to a new QueryParser.
1160 This function is called at the beginning of buildQuery, and modifies
1161 buildQuery's input. If it can handle the input, it returns a query that
1162 buildQuery will not try to parse.
1163 =cut
1164
1165 sub parseQuery {
1166     my ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang) = @_;
1167
1168     my @operators = $operators ? @$operators : ();
1169     my @indexes   = $indexes   ? @$indexes   : ();
1170     my @operands  = $operands  ? @$operands  : ();
1171     my @limits    = $limits    ? @$limits    : ();
1172     my @sort_by   = $sort_by   ? @$sort_by   : ();
1173
1174     my $query = $operands[0];
1175     my $index;
1176     my $term;
1177     my $query_desc;
1178
1179     my $QParser;
1180     $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser') || $query =~ s/^qp=//);
1181     undef $QParser if ($query =~ m/^(ccl=|pqf=|cql=)/ || grep (/\w,\w|\w=\w/, @operands, @indexes) );
1182     undef $QParser if (scalar @limits > 0);
1183
1184     if ($QParser)
1185     {
1186         $QParser->custom_data->{'QueryAutoTruncate'} = C4::Context->preference('QueryAutoTruncate');
1187         $query = '';
1188         for ( my $ii = 0 ; $ii <= @operands ; $ii++ ) {
1189             next unless $operands[$ii];
1190             $query .= $operators[ $ii - 1 ] eq 'or' ? ' || ' : ' && '
1191               if ($query);
1192             if ( $operands[$ii] =~ /^[^"]\W*[-|_\w]*:\w.*[^"]$/ ) {
1193                 $query .= $operands[$ii];
1194             }
1195             elsif ( $indexes[$ii] =~ m/su-/ ) {
1196                 $query .= $indexes[$ii] . '(' . $operands[$ii] . ')';
1197             }
1198             else {
1199                 $query .=
1200                   ( $indexes[$ii] ? "$indexes[$ii]:" : '' ) . $operands[$ii];
1201             }
1202         }
1203         foreach my $limit (@limits) {
1204         }
1205         if ( scalar(@sort_by) > 0 ) {
1206             my $modifier_re =
1207               '#(' . join( '|', @{ $QParser->modifiers } ) . ')';
1208             $query =~ s/$modifier_re//g;
1209             foreach my $modifier (@sort_by) {
1210                 $query .= " #$modifier";
1211             }
1212         }
1213
1214         $query_desc = $query;
1215         $query_desc =~ s/\s+/ /g;
1216         if ( C4::Context->preference("QueryWeightFields") ) {
1217         }
1218         $QParser->add_bib1_filter_map( 'su-br' => 'biblioserver' =>
1219               { 'target_syntax_callback' => \&_handle_exploding_index } );
1220         $QParser->add_bib1_filter_map( 'su-na' => 'biblioserver' =>
1221               { 'target_syntax_callback' => \&_handle_exploding_index } );
1222         $QParser->add_bib1_filter_map( 'su-rl' => 'biblioserver' =>
1223               { 'target_syntax_callback' => \&_handle_exploding_index } );
1224         $QParser->parse($query);
1225         $operands[0] = "pqf=" . $QParser->target_syntax('biblioserver');
1226     }
1227     else {
1228         require Koha::QueryParser::Driver::PQF;
1229         my $modifier_re = '#(' . join( '|', @{Koha::QueryParser::Driver::PQF->modifiers}) . ')';
1230         s/$modifier_re//g for @operands;
1231     }
1232
1233     return ( $operators, \@operands, $indexes, $limits, $sort_by, $scan, $lang, $query_desc);
1234 }
1235
1236 =head2 buildQuery
1237
1238 ( $error, $query,
1239 $simple_query, $query_cgi,
1240 $query_desc, $limit,
1241 $limit_cgi, $limit_desc,
1242 $stopwords_removed, $query_type ) = buildQuery ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang);
1243
1244 Build queries and limits in CCL, CGI, Human,
1245 handle truncation, stemming, field weighting, stopwords, fuzziness, etc.
1246
1247 See verbose embedded documentation.
1248
1249
1250 =cut
1251
1252 sub buildQuery {
1253     my ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang) = @_;
1254
1255     warn "---------\nEnter buildQuery\n---------" if $DEBUG;
1256
1257     my $query_desc;
1258     ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang, $query_desc) = parseQuery($operators, $operands, $indexes, $limits, $sort_by, $scan, $lang);
1259
1260     # dereference
1261     my @operators = $operators ? @$operators : ();
1262     my @indexes   = $indexes   ? @$indexes   : ();
1263     my @operands  = $operands  ? @$operands  : ();
1264     my @limits    = $limits    ? @$limits    : ();
1265     my @sort_by   = $sort_by   ? @$sort_by   : ();
1266
1267     my $stemming         = C4::Context->preference("QueryStemming")        || 0;
1268     my $auto_truncation  = C4::Context->preference("QueryAutoTruncate")    || 0;
1269     my $weight_fields    = C4::Context->preference("QueryWeightFields")    || 0;
1270     my $fuzzy_enabled    = C4::Context->preference("QueryFuzzy")           || 0;
1271     my $remove_stopwords = C4::Context->preference("QueryRemoveStopwords") || 0;
1272
1273     my $query        = $operands[0];
1274     my $simple_query = $operands[0];
1275
1276     # initialize the variables we're passing back
1277     my $query_cgi;
1278     my $query_type;
1279
1280     my $limit;
1281     my $limit_cgi;
1282     my $limit_desc;
1283
1284     my $stopwords_removed;    # flag to determine if stopwords have been removed
1285
1286     my $cclq       = 0;
1287     my $cclindexes = getIndexes();
1288     if ( $query !~ /\s*(ccl=|pqf=|cql=)/ ) {
1289         while ( !$cclq && $query =~ /(?:^|\W)([\w-]+)(,[\w-]+)*[:=]/g ) {
1290             my $dx = lc($1);
1291             $cclq = grep { lc($_) eq $dx } @$cclindexes;
1292         }
1293         $query = "ccl=$query" if $cclq;
1294     }
1295
1296 # for handling ccl, cql, pqf queries in diagnostic mode, skip the rest of the steps
1297 # DIAGNOSTIC ONLY!!
1298     if ( $query =~ /^ccl=/ ) {
1299         my $q=$';
1300         # This is needed otherwise ccl= and &limit won't work together, and
1301         # this happens when selecting a subject on the opac-detail page
1302         @limits = grep {!/^$/} @limits;
1303         if ( @limits ) {
1304             $q .= ' and '.join(' and ', @limits);
1305         }
1306         return ( undef, $q, $q, "q=ccl=".uri_escape($q), $q, '', '', '', '', 'ccl' );
1307     }
1308     if ( $query =~ /^cql=/ ) {
1309         return ( undef, $', $', "q=cql=".uri_escape($'), $', '', '', '', '', 'cql' );
1310     }
1311     if ( $query =~ /^pqf=/ ) {
1312         if ($query_desc) {
1313             $query_cgi = "q=".uri_escape($query_desc);
1314         } else {
1315             $query_desc = $';
1316             $query_cgi = "q=pqf=".uri_escape($');
1317         }
1318         return ( undef, $', $', $query_cgi, $query_desc, '', '', '', '', 'pqf' );
1319     }
1320
1321     # pass nested queries directly
1322     # FIXME: need better handling of some of these variables in this case
1323     # Nested queries aren't handled well and this implementation is flawed and causes users to be
1324     # unable to search for anything containing () commenting out, will be rewritten for 3.4.0
1325 #    if ( $query =~ /(\(|\))/ ) {
1326 #        return (
1327 #            undef,              $query, $simple_query, $query_cgi,
1328 #            $query,             $limit, $limit_cgi,    $limit_desc,
1329 #            $stopwords_removed, 'ccl'
1330 #        );
1331 #    }
1332
1333 # Form-based queries are non-nested and fixed depth, so we can easily modify the incoming
1334 # query operands and indexes and add stemming, truncation, field weighting, etc.
1335 # Once we do so, we'll end up with a value in $query, just like if we had an
1336 # incoming $query from the user
1337     else {
1338         $query = ""
1339           ; # clear it out so we can populate properly with field-weighted, stemmed, etc. query
1340         my $previous_operand
1341           ;    # a flag used to keep track if there was a previous query
1342                # if there was, we can apply the current operator
1343                # for every operand
1344         for ( my $i = 0 ; $i <= @operands ; $i++ ) {
1345
1346             # COMBINE OPERANDS, INDEXES AND OPERATORS
1347             if ( $operands[$i] ) {
1348                 $operands[$i]=~s/^\s+//;
1349
1350               # A flag to determine whether or not to add the index to the query
1351                 my $indexes_set;
1352
1353 # If the user is sophisticated enough to specify an index, turn off field weighting, stemming, and stopword handling
1354                 if ( $operands[$i] =~ /\w(:|=)/ || $scan ) {
1355                     $weight_fields    = 0;
1356                     $stemming         = 0;
1357                     $remove_stopwords = 0;
1358                 } else {
1359                     $operands[$i] =~ s/\?/{?}/g; # need to escape question marks
1360                 }
1361                 my $operand = $operands[$i];
1362                 my $index   = $indexes[$i];
1363
1364                 # Add index-specific attributes
1365                 # Date of Publication
1366                 if ( $index eq 'yr' ) {
1367                     $index .= ",st-numeric";
1368                     $indexes_set++;
1369                                         $stemming = $auto_truncation = $weight_fields = $fuzzy_enabled = $remove_stopwords = 0;
1370                 }
1371
1372                 # Date of Acquisition
1373                 elsif ( $index eq 'acqdate' ) {
1374                     $index .= ",st-date-normalized";
1375                     $indexes_set++;
1376                                         $stemming = $auto_truncation = $weight_fields = $fuzzy_enabled = $remove_stopwords = 0;
1377                 }
1378                 # ISBN,ISSN,Standard Number, don't need special treatment
1379                 elsif ( $index eq 'nb' || $index eq 'ns' ) {
1380                     (
1381                         $stemming,      $auto_truncation,
1382                         $weight_fields, $fuzzy_enabled,
1383                         $remove_stopwords
1384                     ) = ( 0, 0, 0, 0, 0 );
1385
1386                 }
1387
1388                 if(not $index){
1389                     $index = 'kw';
1390                 }
1391
1392                 # Set default structure attribute (word list)
1393                 my $struct_attr = q{};
1394                 unless ( $indexes_set || !$index || $index =~ /,(st-|phr|ext|wrdl)/ || $index =~ /^(nb|ns)$/ ) {
1395                     $struct_attr = ",wrdl";
1396                 }
1397
1398                 # Some helpful index variants
1399                 my $index_plus       = $index . $struct_attr . ':';
1400                 my $index_plus_comma = $index . $struct_attr . ',';
1401
1402                 # Remove Stopwords
1403                 if ($remove_stopwords) {
1404                     ( $operand, $stopwords_removed ) =
1405                       _remove_stopwords( $operand, $index );
1406                     warn "OPERAND w/out STOPWORDS: >$operand<" if $DEBUG;
1407                     warn "REMOVED STOPWORDS: @$stopwords_removed"
1408                       if ( $stopwords_removed && $DEBUG );
1409                 }
1410
1411                 if ($auto_truncation){
1412                         unless ( $index =~ /,(st-|phr|ext)/ ) {
1413                                                 #FIXME only valid with LTR scripts
1414                                                 $operand=join(" ",map{
1415                                                                                         (index($_,"*")>0?"$_":"$_*")
1416                                                                                          }split (/\s+/,$operand));
1417                                                 warn $operand if $DEBUG;
1418                                         }
1419                                 }
1420
1421                 # Detect Truncation
1422                 my $truncated_operand;
1423                 my( $nontruncated, $righttruncated, $lefttruncated,
1424                     $rightlefttruncated, $regexpr
1425                 ) = _detect_truncation( $operand, $index );
1426                 warn
1427 "TRUNCATION: NON:>@$nontruncated< RIGHT:>@$righttruncated< LEFT:>@$lefttruncated< RIGHTLEFT:>@$rightlefttruncated< REGEX:>@$regexpr<"
1428                   if $DEBUG;
1429
1430                 # Apply Truncation
1431                 if (
1432                     scalar(@$righttruncated) + scalar(@$lefttruncated) +
1433                     scalar(@$rightlefttruncated) > 0 )
1434                 {
1435
1436                # Don't field weight or add the index to the query, we do it here
1437                     $indexes_set = 1;
1438                     undef $weight_fields;
1439                     my $previous_truncation_operand;
1440                     if (scalar @$nontruncated) {
1441                         $truncated_operand .= "$index_plus @$nontruncated ";
1442                         $previous_truncation_operand = 1;
1443                     }
1444                     if (scalar @$righttruncated) {
1445                         $truncated_operand .= "and " if $previous_truncation_operand;
1446                         $truncated_operand .= $index_plus_comma . "rtrn:@$righttruncated ";
1447                         $previous_truncation_operand = 1;
1448                     }
1449                     if (scalar @$lefttruncated) {
1450                         $truncated_operand .= "and " if $previous_truncation_operand;
1451                         $truncated_operand .= $index_plus_comma . "ltrn:@$lefttruncated ";
1452                         $previous_truncation_operand = 1;
1453                     }
1454                     if (scalar @$rightlefttruncated) {
1455                         $truncated_operand .= "and " if $previous_truncation_operand;
1456                         $truncated_operand .= $index_plus_comma . "rltrn:@$rightlefttruncated ";
1457                         $previous_truncation_operand = 1;
1458                     }
1459                 }
1460                 $operand = $truncated_operand if $truncated_operand;
1461                 warn "TRUNCATED OPERAND: >$truncated_operand<" if $DEBUG;
1462
1463                 # Handle Stemming
1464                 my $stemmed_operand;
1465                 $stemmed_operand = _build_stemmed_operand($operand, $lang)
1466                                                                                 if $stemming;
1467
1468                 warn "STEMMED OPERAND: >$stemmed_operand<" if $DEBUG;
1469
1470                 # Handle Field Weighting
1471                 my $weighted_operand;
1472                 if ($weight_fields) {
1473                     $weighted_operand = _build_weighted_query( $operand, $stemmed_operand, $index );
1474                     $operand = $weighted_operand;
1475                     $indexes_set = 1;
1476                 }
1477
1478                 warn "FIELD WEIGHTED OPERAND: >$weighted_operand<" if $DEBUG;
1479
1480                 # If there's a previous operand, we need to add an operator
1481                 if ($previous_operand) {
1482
1483                     # User-specified operator
1484                     if ( $operators[ $i - 1 ] ) {
1485                         $query     .= " $operators[$i-1] ";
1486                         $query     .= " $index_plus " unless $indexes_set;
1487                         $query     .= " $operand";
1488                         $query_cgi .= "&op=".uri_escape($operators[$i-1]);
1489                         $query_cgi .= "&idx=".uri_escape($index) if $index;
1490                         $query_cgi .= "&q=".uri_escape($operands[$i]) if $operands[$i];
1491                         $query_desc .=
1492                           " $operators[$i-1] $index_plus $operands[$i]";
1493                     }
1494
1495                     # Default operator is and
1496                     else {
1497                         $query      .= " and ";
1498                         $query      .= "$index_plus " unless $indexes_set;
1499                         $query      .= "$operand";
1500                         $query_cgi  .= "&op=and&idx=".uri_escape($index) if $index;
1501                         $query_cgi  .= "&q=".uri_escape($operands[$i]) if $operands[$i];
1502                         $query_desc .= " and $index_plus $operands[$i]";
1503                     }
1504                 }
1505
1506                 # There isn't a pervious operand, don't need an operator
1507                 else {
1508
1509                     # Field-weighted queries already have indexes set
1510                     $query .= " $index_plus " unless $indexes_set;
1511                     $query .= $operand;
1512                     $query_desc .= " $index_plus $operands[$i]";
1513                     $query_cgi  .= "&idx=".uri_escape($index) if $index;
1514                     $query_cgi  .= "&q=".uri_escape($operands[$i]) if $operands[$i];
1515                     $previous_operand = 1;
1516                 }
1517             }    #/if $operands
1518         }    # /for
1519     }
1520     warn "QUERY BEFORE LIMITS: >$query<" if $DEBUG;
1521
1522     # add limits
1523     my %group_OR_limits;
1524     my $availability_limit;
1525     foreach my $this_limit (@limits) {
1526         next unless $this_limit;
1527         if ( $this_limit =~ /available/ ) {
1528 #
1529 ## 'available' is defined as (items.onloan is NULL) and (items.itemlost = 0)
1530 ## In English:
1531 ## all records not indexed in the onloan register (zebra) and all records with a value of lost equal to 0
1532             $availability_limit .=
1533 "( ( allrecords,AlwaysMatches='' not onloan,AlwaysMatches='') and (lost,st-numeric=0) )"; #or ( allrecords,AlwaysMatches='' not lost,AlwaysMatches='')) )";
1534             $limit_cgi  .= "&limit=available";
1535             $limit_desc .= "";
1536         }
1537
1538         # group_OR_limits, prefixed by mc-
1539         # OR every member of the group
1540         elsif ( $this_limit =~ /mc/ ) {
1541             my ($k,$v) = split(/:/, $this_limit,2);
1542             if ( $k !~ /mc-i(tem)?type/ ) {
1543                 # in case the mc-ccode value has complicating chars like ()'s inside it we wrap in quotes
1544                 $this_limit =~ tr/"//d;
1545                 $this_limit = $k.":\"".$v."\"";
1546             }
1547
1548             $group_OR_limits{$k} .= " or " if $group_OR_limits{$k};
1549             $limit_desc      .= " or " if $group_OR_limits{$k};
1550             $group_OR_limits{$k} .= "$this_limit";
1551             $limit_cgi       .= "&limit=$this_limit";
1552             $limit_desc      .= " $this_limit";
1553         }
1554
1555         # Regular old limits
1556         else {
1557             $limit .= " and " if $limit || $query;
1558             $limit      .= "$this_limit";
1559             $limit_cgi  .= "&limit=$this_limit";
1560             if ($this_limit =~ /^branch:(.+)/) {
1561                 my $branchcode = $1;
1562                 my $branchname = GetBranchName($branchcode);
1563                 if (defined $branchname) {
1564                     $limit_desc .= " branch:$branchname";
1565                 } else {
1566                     $limit_desc .= " $this_limit";
1567                 }
1568             } else {
1569                 $limit_desc .= " $this_limit";
1570             }
1571         }
1572     }
1573     foreach my $k (keys (%group_OR_limits)) {
1574         $limit .= " and " if ( $query || $limit );
1575         $limit .= "($group_OR_limits{$k})";
1576     }
1577     if ($availability_limit) {
1578         $limit .= " and " if ( $query || $limit );
1579         $limit .= "($availability_limit)";
1580     }
1581
1582     # Normalize the query and limit strings
1583     # This is flawed , means we can't search anything with : in it
1584     # if user wants to do ccl or cql, start the query with that
1585 #    $query =~ s/:/=/g;
1586     $query =~ s/(?<=(ti|au|pb|su|an|kw|mc|nb|ns)):/=/g;
1587     $query =~ s/(?<=(wrdl)):/=/g;
1588     $query =~ s/(?<=(trn|phr)):/=/g;
1589     $limit =~ s/:/=/g;
1590     for ( $query, $query_desc, $limit, $limit_desc ) {
1591         s/  +/ /g;    # remove extra spaces
1592         s/^ //g;     # remove any beginning spaces
1593         s/ $//g;     # remove any ending spaces
1594         s/==/=/g;    # remove double == from query
1595     }
1596     $query_cgi =~ s/^&//; # remove unnecessary & from beginning of the query cgi
1597
1598     for ($query_cgi,$simple_query) {
1599         s/"//g;
1600     }
1601     # append the limit to the query
1602     $query .= " " . $limit;
1603
1604     # Warnings if DEBUG
1605     if ($DEBUG) {
1606         warn "QUERY:" . $query;
1607         warn "QUERY CGI:" . $query_cgi;
1608         warn "QUERY DESC:" . $query_desc;
1609         warn "LIMIT:" . $limit;
1610         warn "LIMIT CGI:" . $limit_cgi;
1611         warn "LIMIT DESC:" . $limit_desc;
1612         warn "---------\nLeave buildQuery\n---------";
1613     }
1614     return (
1615         undef,              $query, $simple_query, $query_cgi,
1616         $query_desc,        $limit, $limit_cgi,    $limit_desc,
1617         $stopwords_removed, $query_type
1618     );
1619 }
1620
1621 =head2 searchResults
1622
1623   my @search_results = searchResults($search_context, $searchdesc, $hits,
1624                                      $results_per_page, $offset, $scan,
1625                                      @marcresults);
1626
1627 Format results in a form suitable for passing to the template
1628
1629 =cut
1630
1631 # IMO this subroutine is pretty messy still -- it's responsible for
1632 # building the HTML output for the template
1633 sub searchResults {
1634     my ( $search_context, $searchdesc, $hits, $results_per_page, $offset, $scan, $marcresults ) = @_;
1635     my $dbh = C4::Context->dbh;
1636     my @newresults;
1637
1638     require C4::Items;
1639
1640     $search_context = 'opac' if !$search_context || $search_context ne 'intranet';
1641     my ($is_opac, $hidelostitems);
1642     if ($search_context eq 'opac') {
1643         $hidelostitems = C4::Context->preference('hidelostitems');
1644         $is_opac       = 1;
1645     }
1646
1647     #Build branchnames hash
1648     #find branchname
1649     #get branch information.....
1650     my %branches;
1651     my $bsth =$dbh->prepare("SELECT branchcode,branchname FROM branches"); # FIXME : use C4::Branch::GetBranches
1652     $bsth->execute();
1653     while ( my $bdata = $bsth->fetchrow_hashref ) {
1654         $branches{ $bdata->{'branchcode'} } = $bdata->{'branchname'};
1655     }
1656 # FIXME - We build an authorised values hash here, using the default framework
1657 # though it is possible to have different authvals for different fws.
1658
1659     my $shelflocations =GetKohaAuthorisedValues('items.location','');
1660
1661     # get notforloan authorised value list (see $shelflocations  FIXME)
1662     my $notforloan_authorised_value = GetAuthValCode('items.notforloan','');
1663
1664     #Build itemtype hash
1665     #find itemtype & itemtype image
1666     my %itemtypes;
1667     $bsth =
1668       $dbh->prepare(
1669         "SELECT itemtype,description,imageurl,summary,notforloan FROM itemtypes"
1670       );
1671     $bsth->execute();
1672     while ( my $bdata = $bsth->fetchrow_hashref ) {
1673                 foreach (qw(description imageurl summary notforloan)) {
1674                 $itemtypes{ $bdata->{'itemtype'} }->{$_} = $bdata->{$_};
1675                 }
1676     }
1677
1678     #search item field code
1679     my ($itemtag, undef) = &GetMarcFromKohaField( "items.itemnumber", "" );
1680
1681     ## find column names of items related to MARC
1682     my $sth2 = $dbh->prepare("SHOW COLUMNS FROM items");
1683     $sth2->execute;
1684     my %subfieldstosearch;
1685     while ( ( my $column ) = $sth2->fetchrow ) {
1686         my ( $tagfield, $tagsubfield ) =
1687           &GetMarcFromKohaField( "items." . $column, "" );
1688         if ( defined $tagsubfield ) {
1689             $subfieldstosearch{$column} = $tagsubfield;
1690         }
1691     }
1692
1693     # handle which records to actually retrieve
1694     my $times;
1695     if ( $hits && $offset + $results_per_page <= $hits ) {
1696         $times = $offset + $results_per_page;
1697     }
1698     else {
1699         $times = $hits;  # FIXME: if $hits is undefined, why do we want to equal it?
1700     }
1701
1702         my $marcflavour = C4::Context->preference("marcflavour");
1703     # We get the biblionumber position in MARC
1704     my ($bibliotag,$bibliosubf)=GetMarcFromKohaField('biblio.biblionumber','');
1705
1706     # loop through all of the records we've retrieved
1707     for ( my $i = $offset ; $i <= $times - 1 ; $i++ ) {
1708         my $marcrecord = eval { MARC::File::USMARC::decode( $marcresults->[$i] ); };
1709         if ( $@ ) {
1710             warn "ERROR DECODING RECORD - $@: " . $marcresults->[$i];
1711             next;
1712         }
1713
1714         my $fw = $scan
1715              ? undef
1716              : $bibliotag < 10
1717                ? GetFrameworkCode($marcrecord->field($bibliotag)->data)
1718                : GetFrameworkCode($marcrecord->subfield($bibliotag,$bibliosubf));
1719         my $oldbiblio = TransformMarcToKoha( $dbh, $marcrecord, $fw );
1720         $oldbiblio->{subtitle} = GetRecordValue('subtitle', $marcrecord, $fw);
1721         $oldbiblio->{result_number} = $i + 1;
1722
1723         # add imageurl to itemtype if there is one
1724         $oldbiblio->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} );
1725
1726         $oldbiblio->{'authorised_value_images'}  = ($search_context eq 'opac' && C4::Context->preference('AuthorisedValueImages')) || ($search_context eq 'intranet' && C4::Context->preference('StaffAuthorisedValueImages')) ? C4::Items::get_authorised_value_images( C4::Biblio::get_biblio_authorised_values( $oldbiblio->{'biblionumber'}, $marcrecord ) ) : [];
1727                 $oldbiblio->{normalized_upc}  = GetNormalizedUPC(       $marcrecord,$marcflavour);
1728                 $oldbiblio->{normalized_ean}  = GetNormalizedEAN(       $marcrecord,$marcflavour);
1729                 $oldbiblio->{normalized_oclc} = GetNormalizedOCLCNumber($marcrecord,$marcflavour);
1730                 $oldbiblio->{normalized_isbn} = GetNormalizedISBN(undef,$marcrecord,$marcflavour);
1731                 $oldbiblio->{content_identifier_exists} = 1 if ($oldbiblio->{normalized_isbn} or $oldbiblio->{normalized_oclc} or $oldbiblio->{normalized_ean} or $oldbiblio->{normalized_upc});
1732
1733                 # edition information, if any
1734         $oldbiblio->{edition} = $oldbiblio->{editionstatement};
1735                 $oldbiblio->{description} = $itemtypes{ $oldbiblio->{itemtype} }->{description};
1736  # Build summary if there is one (the summary is defined in the itemtypes table)
1737  # FIXME: is this used anywhere, I think it can be commented out? -- JF
1738         if ( $itemtypes{ $oldbiblio->{itemtype} }->{summary} ) {
1739             my $summary = $itemtypes{ $oldbiblio->{itemtype} }->{summary};
1740             my @fields  = $marcrecord->fields();
1741
1742             my $newsummary;
1743             foreach my $line ( "$summary\n" =~ /(.*)\n/g ){
1744                 my $tags = {};
1745                 foreach my $tag ( $line =~ /\[(\d{3}[\w|\d])\]/ ) {
1746                     $tag =~ /(.{3})(.)/;
1747                     if($marcrecord->field($1)){
1748                         my @abc = $marcrecord->field($1)->subfield($2);
1749                         $tags->{$tag} = $#abc + 1 ;
1750                     }
1751                 }
1752
1753                 # We catch how many times to repeat this line
1754                 my $max = 0;
1755                 foreach my $tag (keys(%$tags)){
1756                     $max = $tags->{$tag} if($tags->{$tag} > $max);
1757                  }
1758
1759                 # we replace, and repeat each line
1760                 for (my $i = 0 ; $i < $max ; $i++){
1761                     my $newline = $line;
1762
1763                     foreach my $tag ( $newline =~ /\[(\d{3}[\w|\d])\]/g ) {
1764                         $tag =~ /(.{3})(.)/;
1765
1766                         if($marcrecord->field($1)){
1767                             my @repl = $marcrecord->field($1)->subfield($2);
1768                             my $subfieldvalue = $repl[$i];
1769
1770                             if (! utf8::is_utf8($subfieldvalue)) {
1771                                 utf8::decode($subfieldvalue);
1772                             }
1773
1774                              $newline =~ s/\[$tag\]/$subfieldvalue/g;
1775                         }
1776                     }
1777                     $newsummary .= "$newline\n";
1778                 }
1779             }
1780
1781             $newsummary =~ s/\[(.*?)]//g;
1782             $newsummary =~ s/\n/<br\/>/g;
1783             $oldbiblio->{summary} = $newsummary;
1784         }
1785
1786         # Pull out the items fields
1787         my @fields = $marcrecord->field($itemtag);
1788         my $marcflavor = C4::Context->preference("marcflavour");
1789         # adding linked items that belong to host records
1790         my $analyticsfield = '773';
1791         if ($marcflavor eq 'MARC21' || $marcflavor eq 'NORMARC') {
1792             $analyticsfield = '773';
1793         } elsif ($marcflavor eq 'UNIMARC') {
1794             $analyticsfield = '461';
1795         }
1796         foreach my $hostfield ( $marcrecord->field($analyticsfield)) {
1797             my $hostbiblionumber = $hostfield->subfield("0");
1798             my $linkeditemnumber = $hostfield->subfield("9");
1799             if(!$hostbiblionumber eq undef){
1800                 my $hostbiblio = GetMarcBiblio($hostbiblionumber, 1);
1801                 my ($itemfield, undef) = GetMarcFromKohaField( 'items.itemnumber', GetFrameworkCode($hostbiblionumber) );
1802                 if(!$hostbiblio eq undef){
1803                     my @hostitems = $hostbiblio->field($itemfield);
1804                     foreach my $hostitem (@hostitems){
1805                         if ($hostitem->subfield("9") eq $linkeditemnumber){
1806                             my $linkeditem =$hostitem;
1807                             # append linked items if they exist
1808                             if (!$linkeditem eq undef){
1809                                 push (@fields, $linkeditem);}
1810                         }
1811                     }
1812                 }
1813             }
1814         }
1815
1816         # Setting item statuses for display
1817         my @available_items_loop;
1818         my @onloan_items_loop;
1819         my @other_items_loop;
1820
1821         my $available_items;
1822         my $onloan_items;
1823         my $other_items;
1824
1825         my $ordered_count         = 0;
1826         my $available_count       = 0;
1827         my $onloan_count          = 0;
1828         my $longoverdue_count     = 0;
1829         my $other_count           = 0;
1830         my $wthdrawn_count        = 0;
1831         my $itemlost_count        = 0;
1832         my $hideatopac_count      = 0;
1833         my $itembinding_count     = 0;
1834         my $itemdamaged_count     = 0;
1835         my $item_in_transit_count = 0;
1836         my $can_place_holds       = 0;
1837         my $item_onhold_count     = 0;
1838         my $items_count           = scalar(@fields);
1839         my $maxitems_pref = C4::Context->preference('maxItemsinSearchResults');
1840         my $maxitems = $maxitems_pref ? $maxitems_pref - 1 : 1;
1841         my @hiddenitems; # hidden itemnumbers based on OpacHiddenItems syspref
1842
1843         # loop through every item
1844         foreach my $field (@fields) {
1845             my $item;
1846
1847             # populate the items hash
1848             foreach my $code ( keys %subfieldstosearch ) {
1849                 $item->{$code} = $field->subfield( $subfieldstosearch{$code} );
1850             }
1851             $item->{description} = $itemtypes{ $item->{itype} }{description};
1852
1853                 # OPAC hidden items
1854             if ($is_opac) {
1855                 # hidden because lost
1856                 if ($hidelostitems && $item->{itemlost}) {
1857                     $hideatopac_count++;
1858                     next;
1859                 }
1860                 # hidden based on OpacHiddenItems syspref
1861                 my @hi = C4::Items::GetHiddenItemnumbers($item);
1862                 if (scalar @hi) {
1863                     push @hiddenitems, @hi;
1864                     $hideatopac_count++;
1865                     next;
1866                 }
1867             }
1868
1869             my $hbranch     = C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch' ? 'homebranch'    : 'holdingbranch';
1870             my $otherbranch = C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch' ? 'holdingbranch' : 'homebranch';
1871
1872             # set item's branch name, use HomeOrHoldingBranch syspref first, fall back to the other one
1873             if ($item->{$hbranch}) {
1874                 $item->{'branchname'} = $branches{$item->{$hbranch}};
1875             }
1876             elsif ($item->{$otherbranch}) {     # Last resort
1877                 $item->{'branchname'} = $branches{$item->{$otherbranch}};
1878             }
1879
1880                         my $prefix = $item->{$hbranch} . '--' . $item->{location} . $item->{itype} . $item->{itemcallnumber};
1881 # For each grouping of items (onloan, available, unavailable), we build a key to store relevant info about that item
1882             my $userenv = C4::Context->userenv;
1883             if ( $item->{onloan} && !(C4::Members::GetHideLostItemsPreference($userenv->{'number'}) && $item->{itemlost}) ) {
1884                 $onloan_count++;
1885                                 my $key = $prefix . $item->{onloan} . $item->{barcode};
1886                                 $onloan_items->{$key}->{due_date} = format_date($item->{onloan});
1887                                 $onloan_items->{$key}->{count}++ if $item->{$hbranch};
1888                                 $onloan_items->{$key}->{branchname} = $item->{branchname};
1889                                 $onloan_items->{$key}->{location} = $shelflocations->{ $item->{location} };
1890                                 $onloan_items->{$key}->{itemcallnumber} = $item->{itemcallnumber};
1891                                 $onloan_items->{$key}->{description} = $item->{description};
1892                                 $onloan_items->{$key}->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $item->{itype} }->{imageurl} );
1893                 # if something's checked out and lost, mark it as 'long overdue'
1894                 if ( $item->{itemlost} ) {
1895                     $onloan_items->{$prefix}->{longoverdue}++;
1896                     $longoverdue_count++;
1897                 } else {        # can place holds as long as item isn't lost
1898                     $can_place_holds = 1;
1899                 }
1900             }
1901
1902          # items not on loan, but still unavailable ( lost, withdrawn, damaged )
1903             else {
1904
1905                 # item is on order
1906                 if ( $item->{notforloan} < 0 ) {
1907                     $ordered_count++;
1908                 }
1909
1910                 # is item in transit?
1911                 my $transfertwhen = '';
1912                 my ($transfertfrom, $transfertto);
1913
1914                 # is item on the reserve shelf?
1915                 my $reservestatus = '';
1916
1917                 unless ($item->{wthdrawn}
1918                         || $item->{itemlost}
1919                         || $item->{damaged}
1920                         || $item->{notforloan}
1921                         || $items_count > 20) {
1922
1923                     # A couple heuristics to limit how many times
1924                     # we query the database for item transfer information, sacrificing
1925                     # accuracy in some cases for speed;
1926                     #
1927                     # 1. don't query if item has one of the other statuses
1928                     # 2. don't check transit status if the bib has
1929                     #    more than 20 items
1930                     #
1931                     # FIXME: to avoid having the query the database like this, and to make
1932                     #        the in transit status count as unavailable for search limiting,
1933                     #        should map transit status to record indexed in Zebra.
1934                     #
1935                     ($transfertwhen, $transfertfrom, $transfertto) = C4::Circulation::GetTransfers($item->{itemnumber});
1936                     $reservestatus = C4::Reserves::GetReserveStatus( $item->{itemnumber}, $oldbiblio->{biblionumber} );
1937                 }
1938
1939                 # item is withdrawn, lost, damaged, not for loan, reserved or in transit
1940                 if (   $item->{wthdrawn}
1941                     || $item->{itemlost}
1942                     || $item->{damaged}
1943                     || $item->{notforloan}
1944                     || $reservestatus eq 'Waiting'
1945                     || ($transfertwhen ne ''))
1946                 {
1947                     $wthdrawn_count++        if $item->{wthdrawn};
1948                     $itemlost_count++        if $item->{itemlost};
1949                     $itemdamaged_count++     if $item->{damaged};
1950                     $item_in_transit_count++ if $transfertwhen ne '';
1951                     $item_onhold_count++     if $reservestatus eq 'Waiting';
1952                     $item->{status} = $item->{wthdrawn} . "-" . $item->{itemlost} . "-" . $item->{damaged} . "-" . $item->{notforloan};
1953
1954                     # can place a hold on a item if
1955                     # not lost nor withdrawn
1956                     # not damaged unless AllowHoldsOnDamagedItems is true
1957                     # item is either for loan or on order (notforloan < 0)
1958                     $can_place_holds = 1
1959                       if (
1960                            !$item->{itemlost}
1961                         && !$item->{wthdrawn}
1962                         && ( !$item->{damaged} || C4::Context->preference('AllowHoldsOnDamagedItems') )
1963                         && ( !$item->{notforloan} || $item->{notforloan} < 0 )
1964                       );
1965
1966                     $other_count++;
1967
1968                     my $key = $prefix . $item->{status};
1969                     foreach (qw(wthdrawn itemlost damaged branchname itemcallnumber)) {
1970                         $other_items->{$key}->{$_} = $item->{$_};
1971                     }
1972                     $other_items->{$key}->{intransit} = ( $transfertwhen ne '' ) ? 1 : 0;
1973                     $other_items->{$key}->{onhold} = ($reservestatus) ? 1 : 0;
1974                     $other_items->{$key}->{notforloan} = GetAuthorisedValueDesc('','',$item->{notforloan},'','',$notforloan_authorised_value) if $notforloan_authorised_value and $item->{notforloan};
1975                                         $other_items->{$key}->{count}++ if $item->{$hbranch};
1976                                         $other_items->{$key}->{location} = $shelflocations->{ $item->{location} };
1977                                         $other_items->{$key}->{description} = $item->{description};
1978                                         $other_items->{$key}->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $item->{itype} }->{imageurl} );
1979                 }
1980                 # item is available
1981                 else {
1982                     $can_place_holds = 1;
1983                     $available_count++;
1984                                         $available_items->{$prefix}->{count}++ if $item->{$hbranch};
1985                                         foreach (qw(branchname itemcallnumber description)) {
1986                         $available_items->{$prefix}->{$_} = $item->{$_};
1987                                         }
1988                                         $available_items->{$prefix}->{location} = $shelflocations->{ $item->{location} };
1989                                         $available_items->{$prefix}->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $item->{itype} }->{imageurl} );
1990                 }
1991             }
1992         }    # notforloan, item level and biblioitem level
1993
1994         # if all items are hidden, do not show the record
1995         if ($items_count > 0 && $hideatopac_count == $items_count) {
1996             next;
1997         }
1998
1999         my ( $availableitemscount, $onloanitemscount, $otheritemscount );
2000         for my $key ( sort keys %$onloan_items ) {
2001             (++$onloanitemscount > $maxitems) and last;
2002             push @onloan_items_loop, $onloan_items->{$key};
2003         }
2004         for my $key ( sort keys %$other_items ) {
2005             (++$otheritemscount > $maxitems) and last;
2006             push @other_items_loop, $other_items->{$key};
2007         }
2008         for my $key ( sort keys %$available_items ) {
2009             (++$availableitemscount > $maxitems) and last;
2010             push @available_items_loop, $available_items->{$key}
2011         }
2012
2013         # XSLT processing of some stuff
2014         use C4::Charset;
2015         SetUTF8Flag($marcrecord);
2016         warn $marcrecord->as_formatted if $DEBUG;
2017         my $interface = $search_context eq 'opac' ? 'OPAC' : '';
2018         if (!$scan && C4::Context->preference($interface . "XSLTResultsDisplay")) {
2019             $oldbiblio->{XSLTResultsRecord} = XSLTParse4Display($oldbiblio->{biblionumber}, $marcrecord, $interface."XSLTResultsDisplay", 1, \@hiddenitems);
2020             # the last parameter tells Koha to clean up the problematic ampersand entities that Zebra outputs
2021         }
2022
2023         # if biblio level itypes are used and itemtype is notforloan, it can't be reserved either
2024         if (!C4::Context->preference("item-level_itypes")) {
2025             if ($itemtypes{ $oldbiblio->{itemtype} }->{notforloan}) {
2026                 $can_place_holds = 0;
2027             }
2028         }
2029         $oldbiblio->{norequests} = 1 unless $can_place_holds;
2030         $oldbiblio->{itemsplural}          = 1 if $items_count > 1;
2031         $oldbiblio->{items_count}          = $items_count;
2032         $oldbiblio->{available_items_loop} = \@available_items_loop;
2033         $oldbiblio->{onloan_items_loop}    = \@onloan_items_loop;
2034         $oldbiblio->{other_items_loop}     = \@other_items_loop;
2035         $oldbiblio->{availablecount}       = $available_count;
2036         $oldbiblio->{availableplural}      = 1 if $available_count > 1;
2037         $oldbiblio->{onloancount}          = $onloan_count;
2038         $oldbiblio->{onloanplural}         = 1 if $onloan_count > 1;
2039         $oldbiblio->{othercount}           = $other_count;
2040         $oldbiblio->{otherplural}          = 1 if $other_count > 1;
2041         $oldbiblio->{wthdrawncount}        = $wthdrawn_count;
2042         $oldbiblio->{itemlostcount}        = $itemlost_count;
2043         $oldbiblio->{damagedcount}         = $itemdamaged_count;
2044         $oldbiblio->{intransitcount}       = $item_in_transit_count;
2045         $oldbiblio->{onholdcount}          = $item_onhold_count;
2046         $oldbiblio->{orderedcount}         = $ordered_count;
2047
2048         if (C4::Context->preference("AlternateHoldingsField") && $items_count == 0) {
2049             my $fieldspec = C4::Context->preference("AlternateHoldingsField");
2050             my $subfields = substr $fieldspec, 3;
2051             my $holdingsep = C4::Context->preference("AlternateHoldingsSeparator") || ' ';
2052             my @alternateholdingsinfo = ();
2053             my @holdingsfields = $marcrecord->field(substr $fieldspec, 0, 3);
2054             my $alternateholdingscount = 0;
2055
2056             for my $field (@holdingsfields) {
2057                 my %holding = ( holding => '' );
2058                 my $havesubfield = 0;
2059                 for my $subfield ($field->subfields()) {
2060                     if ((index $subfields, $$subfield[0]) >= 0) {
2061                         $holding{'holding'} .= $holdingsep if (length $holding{'holding'} > 0);
2062                         $holding{'holding'} .= $$subfield[1];
2063                         $havesubfield++;
2064                     }
2065                 }
2066                 if ($havesubfield) {
2067                     push(@alternateholdingsinfo, \%holding);
2068                     $alternateholdingscount++;
2069                 }
2070             }
2071
2072             $oldbiblio->{'ALTERNATEHOLDINGS'} = \@alternateholdingsinfo;
2073             $oldbiblio->{'alternateholdings_count'} = $alternateholdingscount;
2074         }
2075
2076         push( @newresults, $oldbiblio );
2077     }
2078
2079     return @newresults;
2080 }
2081
2082 =head2 SearchAcquisitions
2083     Search for acquisitions
2084 =cut
2085
2086 sub SearchAcquisitions{
2087     my ($datebegin, $dateend, $itemtypes,$criteria, $orderby) = @_;
2088
2089     my $dbh=C4::Context->dbh;
2090     # Variable initialization
2091     my $str=qq|
2092     SELECT marcxml
2093     FROM biblio
2094     LEFT JOIN biblioitems ON biblioitems.biblionumber=biblio.biblionumber
2095     LEFT JOIN items ON items.biblionumber=biblio.biblionumber
2096     WHERE dateaccessioned BETWEEN ? AND ?
2097     |;
2098
2099     my (@params,@loopcriteria);
2100
2101     push @params, $datebegin->output("iso");
2102     push @params, $dateend->output("iso");
2103
2104     if (scalar(@$itemtypes)>0 and $criteria ne "itemtype" ){
2105         if(C4::Context->preference("item-level_itypes")){
2106             $str .= "AND items.itype IN (?".( ',?' x scalar @$itemtypes - 1 ).") ";
2107         }else{
2108             $str .= "AND biblioitems.itemtype IN (?".( ',?' x scalar @$itemtypes - 1 ).") ";
2109         }
2110         push @params, @$itemtypes;
2111     }
2112
2113     if ($criteria =~/itemtype/){
2114         if(C4::Context->preference("item-level_itypes")){
2115             $str .= "AND items.itype=? ";
2116         }else{
2117             $str .= "AND biblioitems.itemtype=? ";
2118         }
2119
2120         if(scalar(@$itemtypes) == 0){
2121             my $itypes = GetItemTypes();
2122             for my $key (keys %$itypes){
2123                 push @$itemtypes, $key;
2124             }
2125         }
2126
2127         @loopcriteria= @$itemtypes;
2128     }elsif ($criteria=~/itemcallnumber/){
2129         $str .= "AND (items.itemcallnumber LIKE CONCAT(?,'%')
2130                  OR items.itemcallnumber is NULL
2131                  OR items.itemcallnumber = '')";
2132
2133         @loopcriteria = ("AA".."ZZ", "") unless (scalar(@loopcriteria)>0);
2134     }else {
2135         $str .= "AND biblio.title LIKE CONCAT(?,'%') ";
2136         @loopcriteria = ("A".."z") unless (scalar(@loopcriteria)>0);
2137     }
2138
2139     if ($orderby =~ /date_desc/){
2140         $str.=" ORDER BY dateaccessioned DESC";
2141     } else {
2142         $str.=" ORDER BY title";
2143     }
2144
2145     my $qdataacquisitions=$dbh->prepare($str);
2146
2147     my @loopacquisitions;
2148     foreach my $value(@loopcriteria){
2149         push @params,$value;
2150         my %cell;
2151         $cell{"title"}=$value;
2152         $cell{"titlecode"}=$value;
2153
2154         eval{$qdataacquisitions->execute(@params);};
2155
2156         if ($@){ warn "recentacquisitions Error :$@";}
2157         else {
2158             my @loopdata;
2159             while (my $data=$qdataacquisitions->fetchrow_hashref){
2160                 push @loopdata, {"summary"=>GetBiblioSummary( $data->{'marcxml'} ) };
2161             }
2162             $cell{"loopdata"}=\@loopdata;
2163         }
2164         push @loopacquisitions,\%cell if (scalar(@{$cell{loopdata}})>0);
2165         pop @params;
2166     }
2167     $qdataacquisitions->finish;
2168     return \@loopacquisitions;
2169 }
2170
2171 =head2 enabled_staff_search_views
2172
2173 %hash = enabled_staff_search_views()
2174
2175 This function returns a hash that contains three flags obtained from the system
2176 preferences, used to determine whether a particular staff search results view
2177 is enabled.
2178
2179 =over 2
2180
2181 =item C<Output arg:>
2182
2183     * $hash{can_view_MARC} is true only if the MARC view is enabled
2184     * $hash{can_view_ISBD} is true only if the ISBD view is enabled
2185     * $hash{can_view_labeledMARC} is true only if the Labeled MARC view is enabled
2186
2187 =item C<usage in the script:>
2188
2189 =back
2190
2191 $template->param ( C4::Search::enabled_staff_search_views );
2192
2193 =cut
2194
2195 sub enabled_staff_search_views
2196 {
2197         return (
2198                 can_view_MARC                   => C4::Context->preference('viewMARC'),                 # 1 if the staff search allows the MARC view
2199                 can_view_ISBD                   => C4::Context->preference('viewISBD'),                 # 1 if the staff search allows the ISBD view
2200                 can_view_labeledMARC    => C4::Context->preference('viewLabeledMARC'),  # 1 if the staff search allows the Labeled MARC view
2201         );
2202 }
2203
2204 sub AddSearchHistory{
2205         my ($borrowernumber,$session,$query_desc,$query_cgi, $total)=@_;
2206     my $dbh = C4::Context->dbh;
2207
2208     # Add the request the user just made
2209     my $sql = "INSERT INTO search_history(userid, sessionid, query_desc, query_cgi, total, time) VALUES(?, ?, ?, ?, ?, NOW())";
2210     my $sth   = $dbh->prepare($sql);
2211     $sth->execute($borrowernumber, $session, $query_desc, $query_cgi, $total);
2212         return $dbh->last_insert_id(undef, 'search_history', undef,undef,undef);
2213 }
2214
2215 sub GetSearchHistory{
2216         my ($borrowernumber,$session)=@_;
2217     my $dbh = C4::Context->dbh;
2218
2219     # Add the request the user just made
2220     my $query = "SELECT FROM search_history WHERE (userid=? OR sessionid=?)";
2221     my $sth   = $dbh->prepare($query);
2222         $sth->execute($borrowernumber, $session);
2223     return  $sth->fetchall_hashref({});
2224 }
2225
2226 =head2 z3950_search_args
2227
2228 $arrayref = z3950_search_args($matchpoints)
2229
2230 This function returns an array reference that contains the search parameters to be
2231 passed to the Z39.50 search script (z3950_search.pl). The array elements
2232 are hash refs whose keys are name, value and encvalue, and whose values are the
2233 name of a search parameter, the value of that search parameter and the URL encoded
2234 value of that parameter.
2235
2236 The search parameter names are lccn, isbn, issn, title, author, dewey and subject.
2237
2238 The search parameter values are obtained from the bibliographic record whose
2239 data is in a hash reference in $matchpoints, as returned by Biblio::GetBiblioData().
2240
2241 If $matchpoints is a scalar, it is assumed to be an unnamed query descriptor, e.g.
2242 a general purpose search argument. In this case, the returned array contains only
2243 entry: the key is 'title' and the value and encvalue are derived from $matchpoints.
2244
2245 If a search parameter value is undefined or empty, it is not included in the returned
2246 array.
2247
2248 The returned array reference may be passed directly to the template parameters.
2249
2250 =over 2
2251
2252 =item C<Output arg:>
2253
2254     * $array containing hash refs as described above
2255
2256 =item C<usage in the script:>
2257
2258 =back
2259
2260 $data = Biblio::GetBiblioData($bibno);
2261 $template->param ( MYLOOP => C4::Search::z3950_search_args($data) )
2262
2263 *OR*
2264
2265 $template->param ( MYLOOP => C4::Search::z3950_search_args($searchscalar) )
2266
2267 =cut
2268
2269 sub z3950_search_args {
2270     my $bibrec = shift;
2271     my $isbn = Business::ISBN->new($bibrec);
2272
2273     if (defined $isbn && $isbn->is_valid)
2274     {
2275         $bibrec = { isbn => $bibrec } if !ref $bibrec;
2276     }
2277     else {
2278         $bibrec = { title => $bibrec } if !ref $bibrec;
2279     }
2280     my $array = [];
2281     for my $field (qw/ lccn isbn issn title author dewey subject /)
2282     {
2283         my $encvalue = URI::Escape::uri_escape_utf8($bibrec->{$field});
2284         push @$array, { name=>$field, value=>$bibrec->{$field}, encvalue=>$encvalue } if defined $bibrec->{$field};
2285     }
2286     return $array;
2287 }
2288
2289 =head2 GetDistinctValues($field);
2290
2291 C<$field> is a reference to the fields array
2292
2293 =cut
2294
2295 sub GetDistinctValues {
2296     my ($fieldname,$string)=@_;
2297     # returns a reference to a hash of references to branches...
2298     if ($fieldname=~/\./){
2299                         my ($table,$column)=split /\./, $fieldname;
2300                         my $dbh = C4::Context->dbh;
2301                         warn "select DISTINCT($column) as value, count(*) as cnt from $table group by lib order by $column " if $DEBUG;
2302                         my $sth = $dbh->prepare("select DISTINCT($column) as value, count(*) as cnt from $table ".($string?" where $column like \"$string%\"":"")."group by value order by $column ");
2303                         $sth->execute;
2304                         my $elements=$sth->fetchall_arrayref({});
2305                         return $elements;
2306    }
2307    else {
2308                 $string||= qq("");
2309                 my @servers=qw<biblioserver authorityserver>;
2310                 my (@zconns,@results);
2311         for ( my $i = 0 ; $i < @servers ; $i++ ) {
2312                 $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
2313                         $results[$i] =
2314                       $zconns[$i]->scan(
2315                         ZOOM::Query::CCL2RPN->new( qq"$fieldname $string", $zconns[$i])
2316                       );
2317                 }
2318                 # The big moment: asynchronously retrieve results from all servers
2319                 my @elements;
2320         _ZOOM_event_loop(
2321             \@zconns,
2322             \@results,
2323             sub {
2324                 my ( $i, $size ) = @_;
2325                 for ( my $j = 0 ; $j < $size ; $j++ ) {
2326                     my %hashscan;
2327                     @hashscan{qw(value cnt)} =
2328                       $results[ $i - 1 ]->display_term($j);
2329                     push @elements, \%hashscan;
2330                 }
2331             }
2332         );
2333                 return \@elements;
2334    }
2335 }
2336
2337 =head2 _ZOOM_event_loop
2338
2339     _ZOOM_event_loop(\@zconns, \@results, sub {
2340         my ( $i, $size ) = @_;
2341         ....
2342     } );
2343
2344 Processes a ZOOM event loop and passes control to a closure for
2345 processing the results, and destroying the resultsets.
2346
2347 =cut
2348
2349 sub _ZOOM_event_loop {
2350     my ($zconns, $results, $callback) = @_;
2351     while ( ( my $i = ZOOM::event( $zconns ) ) != 0 ) {
2352         my $ev = $zconns->[ $i - 1 ]->last_event();
2353         if ( $ev == ZOOM::Event::ZEND ) {
2354             next unless $results->[ $i - 1 ];
2355             my $size = $results->[ $i - 1 ]->size();
2356             if ( $size > 0 ) {
2357                 $callback->($i, $size);
2358             }
2359         }
2360     }
2361
2362     foreach my $result (@$results) {
2363         $result->destroy();
2364     }
2365 }
2366
2367
2368 END { }    # module clean-up code here (global destructor)
2369
2370 1;
2371 __END__
2372
2373 =head1 AUTHOR
2374
2375 Koha Development Team <http://koha-community.org/>
2376
2377 =cut