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