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