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 utf8;
  40 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
  41
  42 # set the version for version checking
  43 BEGIN {
  44     $VERSION = 3.07.00.049;
  45     $DEBUG = ($ENV{DEBUG}) ? 1 : 0;
  46 }
  47
  48 =head1 NAME
  49
  50 C4::Search - Functions for searching the Koha catalog.
  51
  52 =head1 SYNOPSIS
  53
  54 See opac/opac-search.pl or catalogue/search.pl for example of usage
  55
  56 =head1 DESCRIPTION
  57
  58 This module provides searching functions for Koha's bibliographic databases
  59
  60 =head1 FUNCTIONS
  61
  62 =cut
  63
  64 @ISA    = qw(Exporter);
  65 @EXPORT = qw(
  66   &FindDuplicate
  67   &SimpleSearch
  68   &searchResults
  69   &getRecords
  70   &buildQuery
  71   &AddSearchHistory
  72   &GetDistinctValues
  73   &enabled_staff_search_views
  74   &PurgeSearchHistory
  75 );
  76
  77 # make all your functions, whether exported or not;
  78
  79 =head2 FindDuplicate
  80
  81 ($biblionumber,$biblionumber,$title) = FindDuplicate($record);
  82
  83 This function attempts to find duplicate records using a hard-coded, fairly simplistic algorithm
  84
  85 =cut
  86
  87 sub FindDuplicate {
  88     my ($record) = @_;
  89     my $dbh = C4::Context->dbh;
  90     my $result = TransformMarcToKoha( $dbh, $record, '' );
  91     my $sth;
  92     my $query;
  93     my $search;
  94     my $type;
  95     my ( $biblionumber, $title );
  96
  97     # search duplicate on ISBN, easy and fast..
  98     # ... normalize first
  99     if ( $result->{isbn} ) {
 100         $result->{isbn} =~ s/\(.*$//;
 101         $result->{isbn} =~ s/\s+$//;
 102         $query = "isbn:$result->{isbn}";
 103     }
 104     else {
 105         my $QParser;
 106         $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser'));
 107         my $titleindex;
 108         my $authorindex;
 109         my $op;
 110
 111         if ($QParser) {
 112             $titleindex = 'title|exact';
 113             $authorindex = 'author|exact';
 114             $op = '&&';
 115             $QParser->custom_data->{'QueryAutoTruncate'} = C4::Context->preference('QueryAutoTruncate');
 116         } else {
 117             $titleindex = 'ti,ext';
 118             $authorindex = 'au,ext';
 119             $op = 'and';
 120         }
 121
 122         $result->{title} =~ s /\\//g;
 123         $result->{title} =~ s /\"//g;
 124         $result->{title} =~ s /\(//g;
 125         $result->{title} =~ s /\)//g;
 126
 127         # FIXME: instead of removing operators, could just do
 128         # quotes around the value
 129         $result->{title} =~ s/(and|or|not)//g;
 130         $query = "$titleindex:\"$result->{title}\"";
 131         if   ( $result->{author} ) {
 132             $result->{author} =~ s /\\//g;
 133             $result->{author} =~ s /\"//g;
 134             $result->{author} =~ s /\(//g;
 135             $result->{author} =~ s /\)//g;
 136
 137             # remove valid operators
 138             $result->{author} =~ s/(and|or|not)//g;
 139             $query .= " $op $authorindex:\"$result->{author}\"";
 140         }
 141     }
 142
 143     my ( $error, $searchresults, undef ) = SimpleSearch($query); # FIXME :: hardcoded !
 144     my @results;
 145     if (!defined $error) {
 146         foreach my $possible_duplicate_record (@{$searchresults}) {
 147             my $marcrecord =
 148             MARC::Record->new_from_usmarc($possible_duplicate_record);
 149             my $result = TransformMarcToKoha( $dbh, $marcrecord, '' );
 150
 151             # FIXME :: why 2 $biblionumber ?
 152             if ($result) {
 153                 push @results, $result->{'biblionumber'};
 154                 push @results, $result->{'title'};
 155             }
 156         }
 157     }
 158     return @results;
 159 }
 160
 161 =head2 SimpleSearch
 162
 163 ( $error, $results, $total_hits ) = SimpleSearch( $query, $offset, $max_results, [@servers] );
 164
 165 This function provides a simple search API on the bibliographic catalog
 166
 167 =over 2
 168
 169 =item C<input arg:>
 170
 171     * $query can be a simple keyword or a complete CCL query
 172     * @servers is optional. Defaults to biblioserver as found in koha-conf.xml
 173     * $offset - If present, represents the number of records at the beggining to omit. Defaults to 0
 174     * $max_results - if present, determines the maximum number of records to fetch. undef is All. defaults to undef.
 175
 176
 177 =item C<Return:>
 178
 179     Returns an array consisting of three elements
 180     * $error is undefined unless an error is detected
 181     * $results is a reference to an array of records.
 182     * $total_hits is the number of hits that would have been returned with no limit
 183
 184     If an error is returned the two other return elements are undefined. If error itself is undefined
 185     the other two elements are always defined
 186
 187 =item C<usage in the script:>
 188
 189 =back
 190
 191 my ( $error, $marcresults, $total_hits ) = SimpleSearch($query);
 192
 193 if (defined $error) {
 194     $template->param(query_error => $error);
 195     warn "error: ".$error;
 196     output_html_with_http_headers $input, $cookie, $template->output;
 197     exit;
 198 }
 199
 200 my $hits = @{$marcresults};
 201 my @results;
 202
 203 for my $r ( @{$marcresults} ) {
 204     my $marcrecord = MARC::File::USMARC::decode($r);
 205     my $biblio = TransformMarcToKoha(C4::Context->dbh,$marcrecord,q{});
 206
 207     #build the iarray of hashs for the template.
 208     push @results, {
 209         title           => $biblio->{'title'},
 210         subtitle        => $biblio->{'subtitle'},
 211         biblionumber    => $biblio->{'biblionumber'},
 212         author          => $biblio->{'author'},
 213         publishercode   => $biblio->{'publishercode'},
 214         publicationyear => $biblio->{'publicationyear'},
 215         };
 216
 217 }
 218
 219 $template->param(result=>\@results);
 220
 221 =cut
 222
 223 sub SimpleSearch {
 224     my ( $query, $offset, $max_results, $servers )  = @_;
 225
 226     return ( 'No query entered', undef, undef ) unless $query;
 227     # FIXME hardcoded value. See catalog/search.pl & opac-search.pl too.
 228     my @servers = defined ( $servers ) ? @$servers : ( 'biblioserver' );
 229     my @zoom_queries;
 230     my @tmpresults;
 231     my @zconns;
 232     my $results = [];
 233     my $total_hits = 0;
 234
 235     my $QParser;
 236     $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser') && ! ($query =~ m/\w,\w|\w=\w/));
 237     if ($QParser) {
 238         $QParser->custom_data->{'QueryAutoTruncate'} = C4::Context->preference('QueryAutoTruncate');
 239     }
 240
 241     # Initialize & Search Zebra
 242     for ( my $i = 0 ; $i < @servers ; $i++ ) {
 243         eval {
 244             $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
 245             if ($QParser) {
 246                 $query =~ s/=/:/g;
 247                 $QParser->parse( $query );
 248                 $query = $QParser->target_syntax($servers[$i]);
 249                 $zoom_queries[$i] = new ZOOM::Query::PQF( $query, $zconns[$i]);
 250             } else {
 251                 $query =~ s/:/=/g;
 252                 $zoom_queries[$i] = new ZOOM::Query::CCL2RPN( $query, $zconns[$i]);
 253             }
 254             $tmpresults[$i] = $zconns[$i]->search( $zoom_queries[$i] );
 255
 256             # error handling
 257             my $error =
 258                 $zconns[$i]->errmsg() . " ("
 259               . $zconns[$i]->errcode() . ") "
 260               . $zconns[$i]->addinfo() . " "
 261               . $zconns[$i]->diagset();
 262
 263             return ( $error, undef, undef ) if $zconns[$i]->errcode();
 264         };
 265         if ($@) {
 266
 267             # caught a ZOOM::Exception
 268             my $error =
 269                 $@->message() . " ("
 270               . $@->code() . ") "
 271               . $@->addinfo() . " "
 272               . $@->diagset();
 273             warn $error." for query: $query";
 274             return ( $error, undef, undef );
 275         }
 276     }
 277
 278     _ZOOM_event_loop(
 279         \@zconns,
 280         \@tmpresults,
 281         sub {
 282             my ($i, $size) = @_;
 283             my $first_record = defined($offset) ? $offset + 1 : 1;
 284             my $hits = $tmpresults[ $i - 1 ]->size();
 285             $total_hits += $hits;
 286             my $last_record = $hits;
 287             if ( defined $max_results && $offset + $max_results < $hits ) {
 288                 $last_record = $offset + $max_results;
 289             }
 290
 291             for my $j ( $first_record .. $last_record ) {
 292                 my $record =
 293                   $tmpresults[ $i - 1 ]->record( $j - 1 )->raw()
 294                   ;    # 0 indexed
 295                 push @{$results}, $record;
 296             }
 297         }
 298     );
 299
 300     foreach my $zoom_query (@zoom_queries) {
 301         $zoom_query->destroy();
 302     }
 303
 304     return ( undef, $results, $total_hits );
 305 }
 306
 307 =head2 getRecords
 308
 309 ( undef, $results_hashref, \@facets_loop ) = getRecords (
 310
 311         $koha_query,       $simple_query, $sort_by_ref,    $servers_ref,
 312         $results_per_page, $offset,       $expanded_facet, $branches,$itemtypes,
 313         $query_type,       $scan
 314     );
 315
 316 The all singing, all dancing, multi-server, asynchronous, scanning,
 317 searching, record nabbing, facet-building
 318
 319 See verbse embedded documentation.
 320
 321 =cut
 322
 323 sub getRecords {
 324     my (
 325         $koha_query,       $simple_query, $sort_by_ref,    $servers_ref,
 326         $results_per_page, $offset,       $expanded_facet, $branches,
 327         $itemtypes,        $query_type,   $scan,           $opac
 328     ) = @_;
 329
 330     my @servers = @$servers_ref;
 331     my @sort_by = @$sort_by_ref;
 332
 333     # Initialize variables for the ZOOM connection and results object
 334     my $zconn;
 335     my @zconns;
 336     my @results;
 337     my $results_hashref = ();
 338
 339     # Initialize variables for the faceted results objects
 340     my $facets_counter = ();
 341     my $facets_info    = ();
 342     my $facets         = getFacets();
 343     my $facets_maxrecs = C4::Context->preference('maxRecordsForFacets')||20;
 344
 345     my @facets_loop;    # stores the ref to array of hashes for template facets loop
 346
 347     ### LOOP THROUGH THE SERVERS
 348     for ( my $i = 0 ; $i < @servers ; $i++ ) {
 349         $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
 350
 351 # perform the search, create the results objects
 352 # if this is a local search, use the $koha-query, if it's a federated one, use the federated-query
 353         my $query_to_use = ($servers[$i] =~ /biblioserver/) ? $koha_query : $simple_query;
 354
 355         #$query_to_use = $simple_query if $scan;
 356         warn $simple_query if ( $scan and $DEBUG );
 357
 358         # Check if we've got a query_type defined, if so, use it
 359         eval {
 360             if ($query_type) {
 361                 if ($query_type =~ /^ccl/) {
 362                     $query_to_use =~ s/\:/\=/g;    # change : to = last minute (FIXME)
 363                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::CCL2RPN($query_to_use, $zconns[$i]));
 364                 } elsif ($query_type =~ /^cql/) {
 365                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::CQL($query_to_use, $zconns[$i]));
 366                 } elsif ($query_type =~ /^pqf/) {
 367                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::PQF($query_to_use, $zconns[$i]));
 368                 } else {
 369                     warn "Unknown query_type '$query_type'.  Results undetermined.";
 370                 }
 371             } elsif ($scan) {
 372                     $results[$i] = $zconns[$i]->scan(  new ZOOM::Query::CCL2RPN($query_to_use, $zconns[$i]));
 373             } else {
 374                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::CCL2RPN($query_to_use, $zconns[$i]));
 375             }
 376         };
 377         if ($@) {
 378             warn "WARNING: query problem with $query_to_use " . $@;
 379         }
 380
 381         # Concatenate the sort_by limits and pass them to the results object
 382         # Note: sort will override rank
 383         my $sort_by;
 384         foreach my $sort (@sort_by) {
 385             if ( $sort eq "author_az" || $sort eq "author_asc" ) {
 386                 $sort_by .= "1=1003 <i ";
 387             }
 388             elsif ( $sort eq "author_za" || $sort eq "author_dsc" ) {
 389                 $sort_by .= "1=1003 >i ";
 390             }
 391             elsif ( $sort eq "popularity_asc" ) {
 392                 $sort_by .= "1=9003 <i ";
 393             }
 394             elsif ( $sort eq "popularity_dsc" ) {
 395                 $sort_by .= "1=9003 >i ";
 396             }
 397             elsif ( $sort eq "call_number_asc" ) {
 398                 $sort_by .= "1=8007  <i ";
 399             }
 400             elsif ( $sort eq "call_number_dsc" ) {
 401                 $sort_by .= "1=8007 >i ";
 402             }
 403             elsif ( $sort eq "pubdate_asc" ) {
 404                 $sort_by .= "1=31 <i ";
 405             }
 406             elsif ( $sort eq "pubdate_dsc" ) {
 407                 $sort_by .= "1=31 >i ";
 408             }
 409             elsif ( $sort eq "acqdate_asc" ) {
 410                 $sort_by .= "1=32 <i ";
 411             }
 412             elsif ( $sort eq "acqdate_dsc" ) {
 413                 $sort_by .= "1=32 >i ";
 414             }
 415             elsif ( $sort eq "title_az" || $sort eq "title_asc" ) {
 416                 $sort_by .= "1=4 <i ";
 417             }
 418             elsif ( $sort eq "title_za" || $sort eq "title_dsc" ) {
 419                 $sort_by .= "1=4 >i ";
 420             }
 421             else {
 422                 warn "Ignoring unrecognized sort '$sort' requested" if $sort_by;
 423             }
 424         }
 425         if ($sort_by && !$scan) {
 426             if ( $results[$i]->sort( "yaz", $sort_by ) < 0 ) {
 427                 warn "WARNING sort $sort_by failed";
 428             }
 429         }
 430     }    # finished looping through servers
 431
 432     # The big moment: asynchronously retrieve results from all servers
 433         _ZOOM_event_loop(
 434             \@zconns,
 435             \@results,
 436             sub {
 437                 my ( $i, $size ) = @_;
 438                 my $results_hash;
 439
 440                 # loop through the results
 441                 $results_hash->{'hits'} = $size;
 442                 my $times;
 443                 if ( $offset + $results_per_page <= $size ) {
 444                     $times = $offset + $results_per_page;
 445                 }
 446                 else {
 447                     $times = $size;
 448                 }
 449                 for ( my $j = $offset ; $j < $times ; $j++ ) {
 450                     my $records_hash;
 451                     my $record;
 452
 453                     ## Check if it's an index scan
 454                     if ($scan) {
 455                         my ( $term, $occ ) = $results[ $i - 1 ]->term($j);
 456
 457                  # here we create a minimal MARC record and hand it off to the
 458                  # template just like a normal result ... perhaps not ideal, but
 459                  # it works for now
 460                         my $tmprecord = MARC::Record->new();
 461                         $tmprecord->encoding('UTF-8');
 462                         my $tmptitle;
 463                         my $tmpauthor;
 464
 465                 # the minimal record in author/title (depending on MARC flavour)
 466                         if ( C4::Context->preference("marcflavour") eq
 467                             "UNIMARC" )
 468                         {
 469                             $tmptitle = MARC::Field->new(
 470                                 '200', ' ', ' ',
 471                                 a => $term,
 472                                 f => $occ
 473                             );
 474                             $tmprecord->append_fields($tmptitle);
 475                         }
 476                         else {
 477                             $tmptitle =
 478                               MARC::Field->new( '245', ' ', ' ', a => $term, );
 479                             $tmpauthor =
 480                               MARC::Field->new( '100', ' ', ' ', a => $occ, );
 481                             $tmprecord->append_fields($tmptitle);
 482                             $tmprecord->append_fields($tmpauthor);
 483                         }
 484                         $results_hash->{'RECORDS'}[$j] =
 485                           $tmprecord->as_usmarc();
 486                     }
 487
 488                     # not an index scan
 489                     else {
 490                         $record = $results[ $i - 1 ]->record($j)->raw();
 491
 492                         # warn "RECORD $j:".$record;
 493                         $results_hash->{'RECORDS'}[$j] = $record;
 494                     }
 495
 496                 }
 497                 $results_hashref->{ $servers[ $i - 1 ] } = $results_hash;
 498
 499 # Fill the facets while we're looping, but only for the biblioserver and not for a scan
 500                 if ( !$scan && $servers[ $i - 1 ] =~ /biblioserver/ ) {
 501
 502                     my $jmax =
 503                       $size > $facets_maxrecs ? $facets_maxrecs : $size;
 504                     for my $facet (@$facets) {
 505                         for ( my $j = 0 ; $j < $jmax ; $j++ ) {
 506                             my $render_record =
 507                               $results[ $i - 1 ]->record($j)->render();
 508                             my @used_datas = ();
 509                             foreach my $tag ( @{ $facet->{tags} } ) {
 510
 511                                 # avoid first line
 512                                 my $tag_num = substr( $tag, 0, 3 );
 513                                 my $letters = substr( $tag, 3 );
 514                                 my $field_pattern =
 515                                   '\n' . $tag_num . ' ([^z][^\n]+)';
 516                                 $field_pattern = '\n' . $tag_num . ' ([^\n]+)'
 517                                   if ( int($tag_num) < 10 );
 518                                 my @field_tokens =
 519                                   ( $render_record =~ /$field_pattern/g );
 520                                 foreach my $field_token (@field_tokens) {
 521                                     my @subf = ( $field_token =~
 522                                           /\$([a-zA-Z0-9]) ([^\$]+)/g );
 523                                     my @values;
 524                                     for ( my $i = 0 ; $i < @subf ; $i += 2 ) {
 525                                         if ( $letters =~ $subf[$i] ) {
 526                                             my $value = $subf[ $i + 1 ];
 527                                             $value =~ s/^ *//;
 528                                             $value =~ s/ *$//;
 529                                             push @values, $value;
 530                                         }
 531                                     }
 532                                     my $data = join( $facet->{sep}, @values );
 533                                     unless ( $data ~~ @used_datas ) {
 534                                         $facets_counter->{ $facet->{idx} }
 535                                           ->{$data}++;
 536                                         push @used_datas, $data;
 537                                     }
 538                                 }    # fields
 539                             }    # field codes
 540                         }    # records
 541                         $facets_info->{ $facet->{idx} }->{label_value} =
 542                           $facet->{label};
 543                         $facets_info->{ $facet->{idx} }->{expanded} =
 544                           $facet->{expanded};
 545                     }    # facets
 546                 }
 547
 548                 # warn "connection ", $i-1, ": $size hits";
 549                 # warn $results[$i-1]->record(0)->render() if $size > 0;
 550
 551                 # BUILD FACETS
 552                 if ( $servers[ $i - 1 ] =~ /biblioserver/ ) {
 553                     for my $link_value (
 554                         sort { $facets_counter->{$b} <=> $facets_counter->{$a} }
 555                         keys %$facets_counter
 556                       )
 557                     {
 558                         my $expandable;
 559                         my $number_of_facets;
 560                         my @this_facets_array;
 561                         for my $one_facet (
 562                             sort {
 563                                 $facets_counter->{$link_value}
 564                                   ->{$b} <=> $facets_counter->{$link_value}
 565                                   ->{$a}
 566                             } keys %{ $facets_counter->{$link_value} }
 567                           )
 568                         {
 569                             $number_of_facets++;
 570                             if (   ( $number_of_facets < 6 )
 571                                 || ( $expanded_facet eq $link_value )
 572                                 || ( $facets_info->{$link_value}->{'expanded'} )
 573                               )
 574                             {
 575
 576 # Sanitize the link value : parenthesis, question and exclamation mark will cause errors with CCL
 577                                 my $facet_link_value = $one_facet;
 578                                 $facet_link_value =~ s/[()!?¡¿؟]/ /g;
 579
 580                                 # fix the length that will display in the label,
 581                                 my $facet_label_value = $one_facet;
 582                                 my $facet_max_length  = C4::Context->preference(
 583                                     'FacetLabelTruncationLength')
 584                                   || 20;
 585                                 $facet_label_value =
 586                                   substr( $one_facet, 0, $facet_max_length )
 587                                   . "..."
 588                                   if length($facet_label_value) >
 589                                       $facet_max_length;
 590
 591                             # if it's a branch, label by the name, not the code,
 592                                 if ( $link_value =~ /branch/ ) {
 593                                     if (   defined $branches
 594                                         && ref($branches) eq "HASH"
 595                                         && defined $branches->{$one_facet}
 596                                         && ref( $branches->{$one_facet} ) eq
 597                                         "HASH" )
 598                                     {
 599                                         $facet_label_value =
 600                                           $branches->{$one_facet}
 601                                           ->{'branchname'};
 602                                     }
 603                                     else {
 604                                         $facet_label_value = "*";
 605                                     }
 606                                 }
 607
 608                           # if it's a itemtype, label by the name, not the code,
 609                                 if ( $link_value =~ /itype/ ) {
 610                                     if (   defined $itemtypes
 611                                         && ref($itemtypes) eq "HASH"
 612                                         && defined $itemtypes->{$one_facet}
 613                                         && ref( $itemtypes->{$one_facet} ) eq
 614                                         "HASH" )
 615                                     {
 616                                         $facet_label_value =
 617                                           $itemtypes->{$one_facet}
 618                                           ->{'description'};
 619                                     }
 620                                 }
 621
 622                # also, if it's a location code, use the name instead of the code
 623                                 if ( $link_value =~ /location/ ) {
 624                                     $facet_label_value =
 625                                       GetKohaAuthorisedValueLib( 'LOC',
 626                                         $one_facet, $opac );
 627                                 }
 628
 629                 # but we're down with the whole label being in the link's title.
 630                                 push @this_facets_array,
 631                                   {
 632                                     facet_count =>
 633                                       $facets_counter->{$link_value}
 634                                       ->{$one_facet},
 635                                     facet_label_value => $facet_label_value,
 636                                     facet_title_value => $one_facet,
 637                                     facet_link_value  => $facet_link_value,
 638                                     type_link_value   => $link_value,
 639                                   }
 640                                   if ($facet_label_value);
 641                             }
 642                         }
 643
 644                         # handle expanded option
 645                         unless ( $facets_info->{$link_value}->{'expanded'} ) {
 646                             $expandable = 1
 647                               if ( ( $number_of_facets > 6 )
 648                                 && ( $expanded_facet ne $link_value ) );
 649                         }
 650                         push @facets_loop,
 651                           {
 652                             type_link_value => $link_value,
 653                             type_id         => $link_value . "_id",
 654                             "type_label_"
 655                               . $facets_info->{$link_value}->{'label_value'} =>
 656                               1,
 657                             facets     => \@this_facets_array,
 658                             expandable => $expandable,
 659                             expand     => $link_value,
 660                           }
 661                           unless (
 662                             (
 663                                 $facets_info->{$link_value}->{'label_value'} =~
 664                                 /Libraries/
 665                             )
 666                             and ( C4::Context->preference('singleBranchMode') )
 667                           );
 668                     }
 669                 }
 670             }
 671         );
 672     return ( undef, $results_hashref, \@facets_loop );
 673 }
 674
 675 sub pazGetRecords {
 676     my (
 677         $koha_query,       $simple_query, $sort_by_ref,    $servers_ref,
 678         $results_per_page, $offset,       $expanded_facet, $branches,
 679         $query_type,       $scan
 680     ) = @_;
 681
 682     my $paz = C4::Search::PazPar2->new(C4::Context->config('pazpar2url'));
 683     $paz->init();
 684     $paz->search($simple_query);
 685     sleep 1;   # FIXME: WHY?
 686
 687     # do results
 688     my $results_hashref = {};
 689     my $stats = XMLin($paz->stat);
 690     my $results = XMLin($paz->show($offset, $results_per_page, 'work-title:1'), forcearray => 1);
 691
 692     # for a grouped search result, the number of hits
 693     # is the number of groups returned; 'bib_hits' will have
 694     # the total number of bibs.
 695     $results_hashref->{'biblioserver'}->{'hits'} = $results->{'merged'}->[0];
 696     $results_hashref->{'biblioserver'}->{'bib_hits'} = $stats->{'hits'};
 697
 698     HIT: foreach my $hit (@{ $results->{'hit'} }) {
 699         my $recid = $hit->{recid}->[0];
 700
 701         my $work_title = $hit->{'md-work-title'}->[0];
 702         my $work_author;
 703         if (exists $hit->{'md-work-author'}) {
 704             $work_author = $hit->{'md-work-author'}->[0];
 705         }
 706         my $group_label = (defined $work_author) ? "$work_title / $work_author" : $work_title;
 707
 708         my $result_group = {};
 709         $result_group->{'group_label'} = $group_label;
 710         $result_group->{'group_merge_key'} = $recid;
 711
 712         my $count = 1;
 713         if (exists $hit->{count}) {
 714             $count = $hit->{count}->[0];
 715         }
 716         $result_group->{'group_count'} = $count;
 717
 718         for (my $i = 0; $i < $count; $i++) {
 719             # FIXME -- may need to worry about diacritics here
 720             my $rec = $paz->record($recid, $i);
 721             push @{ $result_group->{'RECORDS'} }, $rec;
 722         }
 723
 724         push @{ $results_hashref->{'biblioserver'}->{'GROUPS'} }, $result_group;
 725     }
 726
 727     # pass through facets
 728     my $termlist_xml = $paz->termlist('author,subject');
 729     my $terms = XMLin($termlist_xml, forcearray => 1);
 730     my @facets_loop = ();
 731     #die Dumper($results);
 732 #    foreach my $list (sort keys %{ $terms->{'list'} }) {
 733 #        my @facets = ();
 734 #        foreach my $facet (sort @{ $terms->{'list'}->{$list}->{'term'} } ) {
 735 #            push @facets, {
 736 #                facet_label_value => $facet->{'name'}->[0],
 737 #            };
 738 #        }
 739 #        push @facets_loop, ( {
 740 #            type_label => $list,
 741 #            facets => \@facets,
 742 #        } );
 743 #    }
 744
 745     return ( undef, $results_hashref, \@facets_loop );
 746 }
 747
 748 # STOPWORDS
 749 sub _remove_stopwords {
 750     my ( $operand, $index ) = @_;
 751     my @stopwords_removed;
 752
 753     # phrase and exact-qualified indexes shouldn't have stopwords removed
 754     if ( $index !~ m/,(phr|ext)/ ) {
 755
 756 # remove stopwords from operand : parse all stopwords & remove them (case insensitive)
 757 #       we use IsAlpha unicode definition, to deal correctly with diacritics.
 758 #       otherwise, a French word like "leçon" woudl be split into "le" "çon", "le"
 759 #       is a stopword, we'd get "çon" and wouldn't find anything...
 760 #
 761                 foreach ( keys %{ C4::Context->stopwords } ) {
 762                         next if ( $_ =~ /(and|or|not)/ );    # don't remove operators
 763                         if ( my ($matched) = ($operand =~
 764                                 /([^\X\p{isAlnum}]\Q$_\E[^\X\p{isAlnum}]|[^\X\p{isAlnum}]\Q$_\E$|^\Q$_\E[^\X\p{isAlnum}])/gi))
 765                         {
 766                                 $operand =~ s/\Q$matched\E/ /gi;
 767                                 push @stopwords_removed, $_;
 768                         }
 769                 }
 770         }
 771     return ( $operand, \@stopwords_removed );
 772 }
 773
 774 # TRUNCATION
 775 sub _detect_truncation {
 776     my ( $operand, $index ) = @_;
 777     my ( @nontruncated, @righttruncated, @lefttruncated, @rightlefttruncated,
 778         @regexpr );
 779     $operand =~ s/^ //g;
 780     my @wordlist = split( /\s/, $operand );
 781     foreach my $word (@wordlist) {
 782         if ( $word =~ s/^\*([^\*]+)\*$/$1/ ) {
 783             push @rightlefttruncated, $word;
 784         }
 785         elsif ( $word =~ s/^\*([^\*]+)$/$1/ ) {
 786             push @lefttruncated, $word;
 787         }
 788         elsif ( $word =~ s/^([^\*]+)\*$/$1/ ) {
 789             push @righttruncated, $word;
 790         }
 791         elsif ( index( $word, "*" ) < 0 ) {
 792             push @nontruncated, $word;
 793         }
 794         else {
 795             push @regexpr, $word;
 796         }
 797     }
 798     return (
 799         \@nontruncated,       \@righttruncated, \@lefttruncated,
 800         \@rightlefttruncated, \@regexpr
 801     );
 802 }
 803
 804 # STEMMING
 805 sub _build_stemmed_operand {
 806     my ($operand,$lang) = @_;
 807     require Lingua::Stem::Snowball ;
 808     my $stemmed_operand=q{};
 809
 810     # If operand contains a digit, it is almost certainly an identifier, and should
 811     # not be stemmed.  This is particularly relevant for ISBNs and ISSNs, which
 812     # can contain the letter "X" - for example, _build_stemmend_operand would reduce
 813     # "014100018X" to "x ", which for a MARC21 database would bring up irrelevant
 814     # results (e.g., "23 x 29 cm." from the 300$c).  Bug 2098.
 815     return $operand if $operand =~ /\d/;
 816
 817 # FIXME: the locale should be set based on the user's language and/or search choice
 818     #warn "$lang";
 819     # Make sure we only use the first two letters from the language code
 820     $lang = lc(substr($lang, 0, 2));
 821     # The language codes for the two variants of Norwegian will now be "nb" and "nn",
 822     # none of which Lingua::Stem::Snowball can use, so we need to "translate" them
 823     if ($lang eq 'nb' || $lang eq 'nn') {
 824       $lang = 'no';
 825     }
 826     my $stemmer = Lingua::Stem::Snowball->new( lang => $lang,
 827                                                encoding => "UTF-8" );
 828
 829     my @words = split( / /, $operand );
 830     my @stems = $stemmer->stem(\@words);
 831     for my $stem (@stems) {
 832         $stemmed_operand .= "$stem";
 833         $stemmed_operand .= "?"
 834           unless ( $stem =~ /(and$|or$|not$)/ ) || ( length($stem) < 3 );
 835         $stemmed_operand .= " ";
 836     }
 837     warn "STEMMED OPERAND: $stemmed_operand" if $DEBUG;
 838     return $stemmed_operand;
 839 }
 840
 841 # FIELD WEIGHTING
 842 sub _build_weighted_query {
 843
 844 # FIELD WEIGHTING - This is largely experimental stuff. What I'm committing works
 845 # pretty well but could work much better if we had a smarter query parser
 846     my ( $operand, $stemmed_operand, $index ) = @_;
 847     my $stemming      = C4::Context->preference("QueryStemming")     || 0;
 848     my $weight_fields = C4::Context->preference("QueryWeightFields") || 0;
 849     my $fuzzy_enabled = C4::Context->preference("QueryFuzzy")        || 0;
 850     $operand =~ s/"/ /g;    # Bug 7518: searches with quotation marks don't work
 851
 852     my $weighted_query .= "(rk=(";    # Specifies that we're applying rank
 853
 854     # Keyword, or, no index specified
 855     if ( ( $index eq 'kw' ) || ( !$index ) ) {
 856         $weighted_query .=
 857           "Title-cover,ext,r1=\"$operand\"";    # exact title-cover
 858         $weighted_query .= " or ti,ext,r2=\"$operand\"";    # exact title
 859         $weighted_query .= " or Title-cover,phr,r3=\"$operand\"";    # phrase title
 860           #$weighted_query .= " or any,ext,r4=$operand";               # exact any
 861           #$weighted_query .=" or kw,wrdl,r5=\"$operand\"";            # word list any
 862         $weighted_query .= " or wrdl,fuzzy,r8=\"$operand\""
 863           if $fuzzy_enabled;    # add fuzzy, word list
 864         $weighted_query .= " or wrdl,right-Truncation,r9=\"$stemmed_operand\""
 865           if ( $stemming and $stemmed_operand )
 866           ;                     # add stemming, right truncation
 867         $weighted_query .= " or wrdl,r9=\"$operand\"";
 868
 869         # embedded sorting: 0 a-z; 1 z-a
 870         # $weighted_query .= ") or (sort1,aut=1";
 871     }
 872
 873     # Barcode searches should skip this process
 874     elsif ( $index eq 'bc' ) {
 875         $weighted_query .= "bc=\"$operand\"";
 876     }
 877
 878     # Authority-number searches should skip this process
 879     elsif ( $index eq 'an' ) {
 880         $weighted_query .= "an=\"$operand\"";
 881     }
 882
 883     # If the index already has more than one qualifier, wrap the operand
 884     # in quotes and pass it back (assumption is that the user knows what they
 885     # are doing and won't appreciate us mucking up their query
 886     elsif ( $index =~ ',' ) {
 887         $weighted_query .= " $index=\"$operand\"";
 888     }
 889
 890     #TODO: build better cases based on specific search indexes
 891     else {
 892         $weighted_query .= " $index,ext,r1=\"$operand\"";    # exact index
 893           #$weighted_query .= " or (title-sort-az=0 or $index,startswithnt,st-word,r3=$operand #)";
 894         $weighted_query .= " or $index,phr,r3=\"$operand\"";    # phrase index
 895         $weighted_query .= " or $index,wrdl,r6=\"$operand\"";    # word list index
 896         $weighted_query .= " or $index,wrdl,fuzzy,r8=\"$operand\""
 897           if $fuzzy_enabled;    # add fuzzy, word list
 898         $weighted_query .= " or $index,wrdl,rt,r9=\"$stemmed_operand\""
 899           if ( $stemming and $stemmed_operand );    # add stemming, right truncation
 900     }
 901
 902     $weighted_query .= "))";                       # close rank specification
 903     return $weighted_query;
 904 }
 905
 906 =head2 getIndexes
 907
 908 Return an array with available indexes.
 909
 910 =cut
 911
 912 sub getIndexes{
 913     my @indexes = (
 914                     # biblio indexes
 915                     'ab',
 916                     'Abstract',
 917                     'acqdate',
 918                     'allrecords',
 919                     'an',
 920                     'Any',
 921                     'at',
 922                     'au',
 923                     'aub',
 924                     'aud',
 925                     'audience',
 926                     'auo',
 927                     'aut',
 928                     'Author',
 929                     'Author-in-order ',
 930                     'Author-personal-bibliography',
 931                     'Authority-Number',
 932                     'authtype',
 933                     'bc',
 934                     'Bib-level',
 935                     'biblionumber',
 936                     'bio',
 937                     'biography',
 938                     'callnum',
 939                     'cfn',
 940                     'Chronological-subdivision',
 941                     'cn-bib-source',
 942                     'cn-bib-sort',
 943                     'cn-class',
 944                     'cn-item',
 945                     'cn-prefix',
 946                     'cn-suffix',
 947                     'cpn',
 948                     'Code-institution',
 949                     'Conference-name',
 950                     'Conference-name-heading',
 951                     'Conference-name-see',
 952                     'Conference-name-seealso',
 953                     'Content-type',
 954                     'Control-number',
 955                     'copydate',
 956                     'Corporate-name',
 957                     'Corporate-name-heading',
 958                     'Corporate-name-see',
 959                     'Corporate-name-seealso',
 960                     'Country-publication',
 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 $withdrawn_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->{withdrawn}
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->{withdrawn}
1941                     || $item->{itemlost}
1942                     || $item->{damaged}
1943                     || $item->{notforloan}
1944                     || $reservestatus eq 'Waiting'
1945                     || ($transfertwhen ne ''))
1946                 {
1947                     $withdrawn_count++        if $item->{withdrawn};
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->{withdrawn} . "-" . $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->{withdrawn}
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(withdrawn 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->{withdrawncount}        = $withdrawn_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 sub PurgeSearchHistory{
2227     my ($pSearchhistory)=@_;
2228     my $dbh = C4::Context->dbh;
2229     my $sth = $dbh->prepare("DELETE FROM search_history WHERE time < DATE_SUB( NOW(), INTERVAL ? DAY )");
2230     $sth->execute($pSearchhistory) or die $dbh->errstr;
2231 }
2232
2233 =head2 z3950_search_args
2234
2235 $arrayref = z3950_search_args($matchpoints)
2236
2237 This function returns an array reference that contains the search parameters to be
2238 passed to the Z39.50 search script (z3950_search.pl). The array elements
2239 are hash refs whose keys are name, value and encvalue, and whose values are the
2240 name of a search parameter, the value of that search parameter and the URL encoded
2241 value of that parameter.
2242
2243 The search parameter names are lccn, isbn, issn, title, author, dewey and subject.
2244
2245 The search parameter values are obtained from the bibliographic record whose
2246 data is in a hash reference in $matchpoints, as returned by Biblio::GetBiblioData().
2247
2248 If $matchpoints is a scalar, it is assumed to be an unnamed query descriptor, e.g.
2249 a general purpose search argument. In this case, the returned array contains only
2250 entry: the key is 'title' and the value and encvalue are derived from $matchpoints.
2251
2252 If a search parameter value is undefined or empty, it is not included in the returned
2253 array.
2254
2255 The returned array reference may be passed directly to the template parameters.
2256
2257 =over 2
2258
2259 =item C<Output arg:>
2260
2261     * $array containing hash refs as described above
2262
2263 =item C<usage in the script:>
2264
2265 =back
2266
2267 $data = Biblio::GetBiblioData($bibno);
2268 $template->param ( MYLOOP => C4::Search::z3950_search_args($data) )
2269
2270 *OR*
2271
2272 $template->param ( MYLOOP => C4::Search::z3950_search_args($searchscalar) )
2273
2274 =cut
2275
2276 sub z3950_search_args {
2277     my $bibrec = shift;
2278     my $isbn = Business::ISBN->new($bibrec);
2279
2280     if (defined $isbn && $isbn->is_valid)
2281     {
2282         $bibrec = { isbn => $bibrec } if !ref $bibrec;
2283     }
2284     else {
2285         $bibrec = { title => $bibrec } if !ref $bibrec;
2286     }
2287     my $array = [];
2288     for my $field (qw/ lccn isbn issn title author dewey subject /)
2289     {
2290         my $encvalue = URI::Escape::uri_escape_utf8($bibrec->{$field});
2291         push @$array, { name=>$field, value=>$bibrec->{$field}, encvalue=>$encvalue } if defined $bibrec->{$field};
2292     }
2293     return $array;
2294 }
2295
2296 =head2 GetDistinctValues($field);
2297
2298 C<$field> is a reference to the fields array
2299
2300 =cut
2301
2302 sub GetDistinctValues {
2303     my ($fieldname,$string)=@_;
2304     # returns a reference to a hash of references to branches...
2305     if ($fieldname=~/\./){
2306                         my ($table,$column)=split /\./, $fieldname;
2307                         my $dbh = C4::Context->dbh;
2308                         warn "select DISTINCT($column) as value, count(*) as cnt from $table group by lib order by $column " if $DEBUG;
2309                         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 ");
2310                         $sth->execute;
2311                         my $elements=$sth->fetchall_arrayref({});
2312                         return $elements;
2313    }
2314    else {
2315                 $string||= qq("");
2316                 my @servers=qw<biblioserver authorityserver>;
2317                 my (@zconns,@results);
2318         for ( my $i = 0 ; $i < @servers ; $i++ ) {
2319                 $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
2320                         $results[$i] =
2321                       $zconns[$i]->scan(
2322                         ZOOM::Query::CCL2RPN->new( qq"$fieldname $string", $zconns[$i])
2323                       );
2324                 }
2325                 # The big moment: asynchronously retrieve results from all servers
2326                 my @elements;
2327         _ZOOM_event_loop(
2328             \@zconns,
2329             \@results,
2330             sub {
2331                 my ( $i, $size ) = @_;
2332                 for ( my $j = 0 ; $j < $size ; $j++ ) {
2333                     my %hashscan;
2334                     @hashscan{qw(value cnt)} =
2335                       $results[ $i - 1 ]->display_term($j);
2336                     push @elements, \%hashscan;
2337                 }
2338             }
2339         );
2340                 return \@elements;
2341    }
2342 }
2343
2344 =head2 _ZOOM_event_loop
2345
2346     _ZOOM_event_loop(\@zconns, \@results, sub {
2347         my ( $i, $size ) = @_;
2348         ....
2349     } );
2350
2351 Processes a ZOOM event loop and passes control to a closure for
2352 processing the results, and destroying the resultsets.
2353
2354 =cut
2355
2356 sub _ZOOM_event_loop {
2357     my ($zconns, $results, $callback) = @_;
2358     while ( ( my $i = ZOOM::event( $zconns ) ) != 0 ) {
2359         my $ev = $zconns->[ $i - 1 ]->last_event();
2360         if ( $ev == ZOOM::Event::ZEND ) {
2361             next unless $results->[ $i - 1 ];
2362             my $size = $results->[ $i - 1 ]->size();
2363             if ( $size > 0 ) {
2364                 $callback->($i, $size);
2365             }
2366         }
2367     }
2368
2369     foreach my $result (@$results) {
2370         $result->destroy();
2371     }
2372 }
2373
2374
2375 END { }    # module clean-up code here (global destructor)
2376
2377 1;
2378 __END__
2379
2380 =head1 AUTHOR
2381
2382 Koha Development Team <http://koha-community.org/>
2383
2384 =cut