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