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->{result_number} = $i + 1;
1496
1497         # add imageurl to itemtype if there is one
1498         $oldbiblio->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} );
1499
1500         $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 ) ) : [];
1501                 $oldbiblio->{normalized_upc}  = GetNormalizedUPC(       $marcrecord,$marcflavour);
1502                 $oldbiblio->{normalized_ean}  = GetNormalizedEAN(       $marcrecord,$marcflavour);
1503                 $oldbiblio->{normalized_oclc} = GetNormalizedOCLCNumber($marcrecord,$marcflavour);
1504                 $oldbiblio->{normalized_isbn} = GetNormalizedISBN(undef,$marcrecord,$marcflavour);
1505                 $oldbiblio->{content_identifier_exists} = 1 if ($oldbiblio->{normalized_isbn} or $oldbiblio->{normalized_oclc} or $oldbiblio->{normalized_ean} or $oldbiblio->{normalized_upc});
1506
1507                 # edition information, if any
1508         $oldbiblio->{edition} = $oldbiblio->{editionstatement};
1509                 $oldbiblio->{description} = $itemtypes{ $oldbiblio->{itemtype} }->{description};
1510  # Build summary if there is one (the summary is defined in the itemtypes table)
1511  # FIXME: is this used anywhere, I think it can be commented out? -- JF
1512         if ( $itemtypes{ $oldbiblio->{itemtype} }->{summary} ) {
1513             my $summary = $itemtypes{ $oldbiblio->{itemtype} }->{summary};
1514             my @fields  = $marcrecord->fields();
1515
1516             my $newsummary;
1517             foreach my $line ( "$summary\n" =~ /(.*)\n/g ){
1518                 my $tags = {};
1519                 foreach my $tag ( $line =~ /\[(\d{3}[\w|\d])\]/ ) {
1520                     $tag =~ /(.{3})(.)/;
1521                     if($marcrecord->field($1)){
1522                         my @abc = $marcrecord->field($1)->subfield($2);
1523                         $tags->{$tag} = $#abc + 1 ;
1524                     }
1525                 }
1526
1527                 # We catch how many times to repeat this line
1528                 my $max = 0;
1529                 foreach my $tag (keys(%$tags)){
1530                     $max = $tags->{$tag} if($tags->{$tag} > $max);
1531                  }
1532
1533                 # we replace, and repeat each line
1534                 for (my $i = 0 ; $i < $max ; $i++){
1535                     my $newline = $line;
1536
1537                     foreach my $tag ( $newline =~ /\[(\d{3}[\w|\d])\]/g ) {
1538                         $tag =~ /(.{3})(.)/;
1539
1540                         if($marcrecord->field($1)){
1541                             my @repl = $marcrecord->field($1)->subfield($2);
1542                             my $subfieldvalue = $repl[$i];
1543
1544                             if (! utf8::is_utf8($subfieldvalue)) {
1545                                 utf8::decode($subfieldvalue);
1546                             }
1547
1548                              $newline =~ s/\[$tag\]/$subfieldvalue/g;
1549                         }
1550                     }
1551                     $newsummary .= "$newline\n";
1552                 }
1553             }
1554
1555             $newsummary =~ s/\[(.*?)]//g;
1556             $newsummary =~ s/\n/<br\/>/g;
1557             $oldbiblio->{summary} = $newsummary;
1558         }
1559
1560         # Pull out the items fields
1561         my @fields = $marcrecord->field($itemtag);
1562         my $marcflavor = C4::Context->preference("marcflavour");
1563         # adding linked items that belong to host records
1564         my $analyticsfield = '773';
1565         if ($marcflavor eq 'MARC21' || $marcflavor eq 'NORMARC') {
1566             $analyticsfield = '773';
1567         } elsif ($marcflavor eq 'UNIMARC') {
1568             $analyticsfield = '461';
1569         }
1570         foreach my $hostfield ( $marcrecord->field($analyticsfield)) {
1571             my $hostbiblionumber = $hostfield->subfield("0");
1572             my $linkeditemnumber = $hostfield->subfield("9");
1573             if(!$hostbiblionumber eq undef){
1574                 my $hostbiblio = GetMarcBiblio($hostbiblionumber, 1);
1575                 my ($itemfield, undef) = GetMarcFromKohaField( 'items.itemnumber', GetFrameworkCode($hostbiblionumber) );
1576                 if(!$hostbiblio eq undef){
1577                     my @hostitems = $hostbiblio->field($itemfield);
1578                     foreach my $hostitem (@hostitems){
1579                         if ($hostitem->subfield("9") eq $linkeditemnumber){
1580                             my $linkeditem =$hostitem;
1581                             # append linked items if they exist
1582                             if (!$linkeditem eq undef){
1583                                 push (@fields, $linkeditem);}
1584                         }
1585                     }
1586                 }
1587             }
1588         }
1589
1590         # Setting item statuses for display
1591         my @available_items_loop;
1592         my @onloan_items_loop;
1593         my @other_items_loop;
1594
1595         my $available_items;
1596         my $onloan_items;
1597         my $other_items;
1598
1599         my $ordered_count         = 0;
1600         my $available_count       = 0;
1601         my $onloan_count          = 0;
1602         my $longoverdue_count     = 0;
1603         my $other_count           = 0;
1604         my $wthdrawn_count        = 0;
1605         my $itemlost_count        = 0;
1606         my $itembinding_count     = 0;
1607         my $itemdamaged_count     = 0;
1608         my $item_in_transit_count = 0;
1609         my $can_place_holds       = 0;
1610         my $item_onhold_count     = 0;
1611         my $items_count           = scalar(@fields);
1612         my $maxitems =
1613           ( C4::Context->preference('maxItemsinSearchResults') )
1614           ? C4::Context->preference('maxItemsinSearchResults') - 1
1615           : 1;
1616
1617         # loop through every item
1618         foreach my $field (@fields) {
1619             my $item;
1620
1621             # populate the items hash
1622             foreach my $code ( keys %subfieldstosearch ) {
1623                 $item->{$code} = $field->subfield( $subfieldstosearch{$code} );
1624             }
1625
1626                 # Hidden items
1627                 my @items = ($item);
1628                 my (@hiddenitems) = GetHiddenItemnumbers(@items);
1629             $item->{'hideatopac'} = 1 if (@hiddenitems);
1630
1631             my $hbranch     = C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch' ? 'homebranch'    : 'holdingbranch';
1632             my $otherbranch = C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch' ? 'holdingbranch' : 'homebranch';
1633
1634             # set item's branch name, use HomeOrHoldingBranch syspref first, fall back to the other one
1635             if ($item->{$hbranch}) {
1636                 $item->{'branchname'} = $branches{$item->{$hbranch}};
1637             }
1638             elsif ($item->{$otherbranch}) {     # Last resort
1639                 $item->{'branchname'} = $branches{$item->{$otherbranch}};
1640             }
1641
1642                         my $prefix = $item->{$hbranch} . '--' . $item->{location} . $item->{itype} . $item->{itemcallnumber};
1643 # For each grouping of items (onloan, available, unavailable), we build a key to store relevant info about that item
1644             my $userenv = C4::Context->userenv;
1645             if ( $item->{onloan} && !(C4::Members::GetHideLostItemsPreference($userenv->{'number'}) && $item->{itemlost}) ) {
1646                 $onloan_count++;
1647                                 my $key = $prefix . $item->{onloan} . $item->{barcode};
1648                                 $onloan_items->{$key}->{due_date} = format_date($item->{onloan});
1649                                 $onloan_items->{$key}->{count}++ if $item->{$hbranch};
1650                                 $onloan_items->{$key}->{branchname} = $item->{branchname};
1651                                 $onloan_items->{$key}->{location} = $shelflocations->{ $item->{location} };
1652                                 $onloan_items->{$key}->{itemcallnumber} = $item->{itemcallnumber};
1653                                 $onloan_items->{$key}->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $item->{itype} }->{imageurl} );
1654                 # if something's checked out and lost, mark it as 'long overdue'
1655                 if ( $item->{itemlost} ) {
1656                     $onloan_items->{$prefix}->{longoverdue}++;
1657                     $longoverdue_count++;
1658                 } else {        # can place holds as long as item isn't lost
1659                     $can_place_holds = 1;
1660                 }
1661             }
1662
1663          # items not on loan, but still unavailable ( lost, withdrawn, damaged )
1664             else {
1665
1666                 # item is on order
1667                 if ( $item->{notforloan} == -1 ) {
1668                     $ordered_count++;
1669                 }
1670
1671                 # is item in transit?
1672                 my $transfertwhen = '';
1673                 my ($transfertfrom, $transfertto);
1674
1675                 # is item on the reserve shelf?
1676                 my $reservestatus = '';
1677                 my $reserveitem;
1678
1679                 unless ($item->{wthdrawn}
1680                         || $item->{itemlost}
1681                         || $item->{damaged}
1682                         || $item->{notforloan}
1683                         || $items_count > 20) {
1684
1685                     # A couple heuristics to limit how many times
1686                     # we query the database for item transfer information, sacrificing
1687                     # accuracy in some cases for speed;
1688                     #
1689                     # 1. don't query if item has one of the other statuses
1690                     # 2. don't check transit status if the bib has
1691                     #    more than 20 items
1692                     #
1693                     # FIXME: to avoid having the query the database like this, and to make
1694                     #        the in transit status count as unavailable for search limiting,
1695                     #        should map transit status to record indexed in Zebra.
1696                     #
1697                     ($transfertwhen, $transfertfrom, $transfertto) = C4::Circulation::GetTransfers($item->{itemnumber});
1698                     ($reservestatus, $reserveitem, undef) = C4::Reserves::CheckReserves($item->{itemnumber});
1699                 }
1700
1701                 # item is withdrawn, lost, damaged, not for loan, reserved or in transit
1702                 if (   $item->{wthdrawn}
1703                     || $item->{itemlost}
1704                     || $item->{damaged}
1705                     || $item->{notforloan} > 0
1706                     || $item->{hideatopac}
1707                     || $reservestatus eq 'Waiting'
1708                     || ($transfertwhen ne ''))
1709                 {
1710                     $wthdrawn_count++        if $item->{wthdrawn};
1711                     $itemlost_count++        if $item->{itemlost};
1712                     $itemdamaged_count++     if $item->{damaged};
1713                     $item_in_transit_count++ if $transfertwhen ne '';
1714                     $item_onhold_count++     if $reservestatus eq 'Waiting';
1715                     $item->{status} = $item->{wthdrawn} . "-" . $item->{itemlost} . "-" . $item->{damaged} . "-" . $item->{notforloan};
1716
1717                     # can place hold on item ?
1718                     if ((!$item->{damaged} || C4::Context->preference('AllowHoldsOnDamagedItems'))
1719                       && !$item->{itemlost}
1720                       && !$item->{withdrawn}
1721                     ) {
1722                         $can_place_holds = 1;
1723                     }
1724
1725                     $other_count++;
1726
1727                     my $key = $prefix . $item->{status};
1728                     foreach (qw(wthdrawn itemlost damaged branchname itemcallnumber hideatopac)) {
1729                         $other_items->{$key}->{$_} = $item->{$_};
1730                     }
1731                     $other_items->{$key}->{intransit} = ( $transfertwhen ne '' ) ? 1 : 0;
1732                     $other_items->{$key}->{onhold} = ($reservestatus) ? 1 : 0;
1733                                         $other_items->{$key}->{notforloan} = GetAuthorisedValueDesc('','',$item->{notforloan},'','',$notforloan_authorised_value) if $notforloan_authorised_value;
1734                                         $other_items->{$key}->{count}++ if $item->{$hbranch};
1735                                         $other_items->{$key}->{location} = $shelflocations->{ $item->{location} };
1736                                         $other_items->{$key}->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $item->{itype} }->{imageurl} );
1737                 }
1738                 # item is available
1739                 else {
1740                     $can_place_holds = 1;
1741                     $available_count++;
1742                                         $available_items->{$prefix}->{count}++ if $item->{$hbranch};
1743                                         foreach (qw(branchname itemcallnumber hideatopac)) {
1744                         $available_items->{$prefix}->{$_} = $item->{$_};
1745                                         }
1746                                         $available_items->{$prefix}->{location} = $shelflocations->{ $item->{location} };
1747                                         $available_items->{$prefix}->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $item->{itype} }->{imageurl} );
1748                 }
1749             }
1750         }    # notforloan, item level and biblioitem level
1751         my ( $availableitemscount, $onloanitemscount, $otheritemscount );
1752         $maxitems =
1753           ( C4::Context->preference('maxItemsinSearchResults') )
1754           ? C4::Context->preference('maxItemsinSearchResults') - 1
1755           : 1;
1756         for my $key ( sort keys %$onloan_items ) {
1757             (++$onloanitemscount > $maxitems) and last;
1758             push @onloan_items_loop, $onloan_items->{$key};
1759         }
1760         for my $key ( sort keys %$other_items ) {
1761             (++$otheritemscount > $maxitems) and last;
1762             push @other_items_loop, $other_items->{$key};
1763         }
1764         for my $key ( sort keys %$available_items ) {
1765             (++$availableitemscount > $maxitems) and last;
1766             push @available_items_loop, $available_items->{$key}
1767         }
1768
1769         # XSLT processing of some stuff
1770         use C4::Charset;
1771         SetUTF8Flag($marcrecord);
1772         $debug && warn $marcrecord->as_formatted;
1773         if (!$scan && $search_context eq 'opac' && C4::Context->preference("OPACXSLTResultsDisplay")) {
1774             # FIXME note that XSLTResultsDisplay (use of XSLT to format staff interface bib search results)
1775             # is not implemented yet
1776             $oldbiblio->{XSLTResultsRecord} = XSLTParse4Display($oldbiblio->{biblionumber}, $marcrecord, 'Results',
1777                                                                 $search_context, 1);
1778                 # the last parameter tells Koha to clean up the problematic ampersand entities that Zebra outputs
1779
1780         }
1781
1782         # if biblio level itypes are used and itemtype is notforloan, it can't be reserved either
1783         if (!C4::Context->preference("item-level_itypes")) {
1784             if ($itemtypes{ $oldbiblio->{itemtype} }->{notforloan}) {
1785                 $can_place_holds = 0;
1786             }
1787         }
1788         $oldbiblio->{norequests} = 1 unless $can_place_holds;
1789         $oldbiblio->{itemsplural}          = 1 if $items_count > 1;
1790         $oldbiblio->{items_count}          = $items_count;
1791         $oldbiblio->{available_items_loop} = \@available_items_loop;
1792         $oldbiblio->{onloan_items_loop}    = \@onloan_items_loop;
1793         $oldbiblio->{other_items_loop}     = \@other_items_loop;
1794         $oldbiblio->{availablecount}       = $available_count;
1795         $oldbiblio->{availableplural}      = 1 if $available_count > 1;
1796         $oldbiblio->{onloancount}          = $onloan_count;
1797         $oldbiblio->{onloanplural}         = 1 if $onloan_count > 1;
1798         $oldbiblio->{othercount}           = $other_count;
1799         $oldbiblio->{otherplural}          = 1 if $other_count > 1;
1800         $oldbiblio->{wthdrawncount}        = $wthdrawn_count;
1801         $oldbiblio->{itemlostcount}        = $itemlost_count;
1802         $oldbiblio->{damagedcount}         = $itemdamaged_count;
1803         $oldbiblio->{intransitcount}       = $item_in_transit_count;
1804         $oldbiblio->{onholdcount}          = $item_onhold_count;
1805         $oldbiblio->{orderedcount}         = $ordered_count;
1806         $oldbiblio->{isbn} =~
1807           s/-//g;    # deleting - in isbn to enable amazon content
1808
1809         if (C4::Context->preference("AlternateHoldingsField") && $items_count == 0) {
1810             my $fieldspec = C4::Context->preference("AlternateHoldingsField");
1811             my $subfields = substr $fieldspec, 3;
1812             my $holdingsep = C4::Context->preference("AlternateHoldingsSeparator") || ' ';
1813             my @alternateholdingsinfo = ();
1814             my @holdingsfields = $marcrecord->field(substr $fieldspec, 0, 3);
1815             my $alternateholdingscount = 0;
1816
1817             for my $field (@holdingsfields) {
1818                 my %holding = ( holding => '' );
1819                 my $havesubfield = 0;
1820                 for my $subfield ($field->subfields()) {
1821                     if ((index $subfields, $$subfield[0]) >= 0) {
1822                         $holding{'holding'} .= $holdingsep if (length $holding{'holding'} > 0);
1823                         $holding{'holding'} .= $$subfield[1];
1824                         $havesubfield++;
1825                     }
1826                 }
1827                 if ($havesubfield) {
1828                     push(@alternateholdingsinfo, \%holding);
1829                     $alternateholdingscount++;
1830                 }
1831             }
1832
1833             $oldbiblio->{'ALTERNATEHOLDINGS'} = \@alternateholdingsinfo;
1834             $oldbiblio->{'alternateholdings_count'} = $alternateholdingscount;
1835         }
1836
1837         push( @newresults, $oldbiblio )
1838             if(not $hidelostitems
1839                or (($items_count > $itemlost_count )
1840                     && $hidelostitems));
1841     }
1842
1843     return @newresults;
1844 }
1845
1846 =head2 SearchAcquisitions
1847     Search for acquisitions
1848 =cut
1849
1850 sub SearchAcquisitions{
1851     my ($datebegin, $dateend, $itemtypes,$criteria, $orderby) = @_;
1852
1853     my $dbh=C4::Context->dbh;
1854     # Variable initialization
1855     my $str=qq|
1856     SELECT marcxml
1857     FROM biblio
1858     LEFT JOIN biblioitems ON biblioitems.biblionumber=biblio.biblionumber
1859     LEFT JOIN items ON items.biblionumber=biblio.biblionumber
1860     WHERE dateaccessioned BETWEEN ? AND ?
1861     |;
1862
1863     my (@params,@loopcriteria);
1864
1865     push @params, $datebegin->output("iso");
1866     push @params, $dateend->output("iso");
1867
1868     if (scalar(@$itemtypes)>0 and $criteria ne "itemtype" ){
1869         if(C4::Context->preference("item-level_itypes")){
1870             $str .= "AND items.itype IN (?".( ',?' x scalar @$itemtypes - 1 ).") ";
1871         }else{
1872             $str .= "AND biblioitems.itemtype IN (?".( ',?' x scalar @$itemtypes - 1 ).") ";
1873         }
1874         push @params, @$itemtypes;
1875     }
1876
1877     if ($criteria =~/itemtype/){
1878         if(C4::Context->preference("item-level_itypes")){
1879             $str .= "AND items.itype=? ";
1880         }else{
1881             $str .= "AND biblioitems.itemtype=? ";
1882         }
1883
1884         if(scalar(@$itemtypes) == 0){
1885             my $itypes = GetItemTypes();
1886             for my $key (keys %$itypes){
1887                 push @$itemtypes, $key;
1888             }
1889         }
1890
1891         @loopcriteria= @$itemtypes;
1892     }elsif ($criteria=~/itemcallnumber/){
1893         $str .= "AND (items.itemcallnumber LIKE CONCAT(?,'%')
1894                  OR items.itemcallnumber is NULL
1895                  OR items.itemcallnumber = '')";
1896
1897         @loopcriteria = ("AA".."ZZ", "") unless (scalar(@loopcriteria)>0);
1898     }else {
1899         $str .= "AND biblio.title LIKE CONCAT(?,'%') ";
1900         @loopcriteria = ("A".."z") unless (scalar(@loopcriteria)>0);
1901     }
1902
1903     if ($orderby =~ /date_desc/){
1904         $str.=" ORDER BY dateaccessioned DESC";
1905     } else {
1906         $str.=" ORDER BY title";
1907     }
1908
1909     my $qdataacquisitions=$dbh->prepare($str);
1910
1911     my @loopacquisitions;
1912     foreach my $value(@loopcriteria){
1913         push @params,$value;
1914         my %cell;
1915         $cell{"title"}=$value;
1916         $cell{"titlecode"}=$value;
1917
1918         eval{$qdataacquisitions->execute(@params);};
1919
1920         if ($@){ warn "recentacquisitions Error :$@";}
1921         else {
1922             my @loopdata;
1923             while (my $data=$qdataacquisitions->fetchrow_hashref){
1924                 push @loopdata, {"summary"=>GetBiblioSummary( $data->{'marcxml'} ) };
1925             }
1926             $cell{"loopdata"}=\@loopdata;
1927         }
1928         push @loopacquisitions,\%cell if (scalar(@{$cell{loopdata}})>0);
1929         pop @params;
1930     }
1931     $qdataacquisitions->finish;
1932     return \@loopacquisitions;
1933 }
1934 #----------------------------------------------------------------------
1935 #
1936 # Non-Zebra GetRecords#
1937 #----------------------------------------------------------------------
1938
1939 =head2 NZgetRecords
1940
1941   NZgetRecords has the same API as zera getRecords, even if some parameters are not managed
1942
1943 =cut
1944
1945 sub NZgetRecords {
1946     my (
1947         $query,            $simple_query, $sort_by_ref,    $servers_ref,
1948         $results_per_page, $offset,       $expanded_facet, $branches,
1949         $query_type,       $scan
1950     ) = @_;
1951     warn "query =$query" if $DEBUG;
1952     my $result = NZanalyse($query);
1953     warn "results =$result" if $DEBUG;
1954     return ( undef,
1955         NZorder( $result, @$sort_by_ref[0], $results_per_page, $offset ),
1956         undef );
1957 }
1958
1959 =head2 NZanalyse
1960
1961   NZanalyse : get a CQL string as parameter, and returns a list of biblionumber;title,biblionumber;title,...
1962   the list is built from an inverted index in the nozebra SQL table
1963   note that title is here only for convenience : the sorting will be very fast when requested on title
1964   if the sorting is requested on something else, we will have to reread all results, and that may be longer.
1965
1966 =cut
1967
1968 sub NZanalyse {
1969     my ( $string, $server ) = @_;
1970 #     warn "---------"       if $DEBUG;
1971     warn " NZanalyse" if $DEBUG;
1972 #     warn "---------"       if $DEBUG;
1973
1974  # $server contains biblioserver or authorities, depending on what we search on.
1975  #warn "querying : $string on $server";
1976     $server = 'biblioserver' unless $server;
1977
1978 # if we have a ", replace the content to discard temporarily any and/or/not inside
1979     my $commacontent;
1980     if ( $string =~ /"/ ) {
1981         $string =~ s/"(.*?)"/__X__/;
1982         $commacontent = $1;
1983         warn "commacontent : $commacontent" if $DEBUG;
1984     }
1985
1986 # split the query string in 3 parts : X AND Y means : $left="X", $operand="AND" and $right="Y"
1987 # then, call again NZanalyse with $left and $right
1988 # (recursive until we find a leaf (=> something without and/or/not)
1989 # delete repeated operator... Would then go in infinite loop
1990     while ( $string =~ s/( and| or| not| AND| OR| NOT)\1/$1/g ) {
1991     }
1992
1993     #process parenthesis before.
1994     if ( $string =~ /^\s*\((.*)\)(( and | or | not | AND | OR | NOT )(.*))?/ ) {
1995         my $left     = $1;
1996         my $right    = $4;
1997         my $operator = lc($3);   # FIXME: and/or/not are operators, not operands
1998         warn
1999 "dealing w/parenthesis before recursive sub call. left :$left operator:$operator right:$right"
2000           if $DEBUG;
2001         my $leftresult = NZanalyse( $left, $server );
2002         if ($operator) {
2003             my $rightresult = NZanalyse( $right, $server );
2004
2005             # OK, we have the results for right and left part of the query
2006             # depending of operand, intersect, union or exclude both lists
2007             # to get a result list
2008             if ( $operator eq ' and ' ) {
2009                 return NZoperatorAND($leftresult,$rightresult);
2010             }
2011             elsif ( $operator eq ' or ' ) {
2012
2013                 # just merge the 2 strings
2014                 return $leftresult . $rightresult;
2015             }
2016             elsif ( $operator eq ' not ' ) {
2017                 return NZoperatorNOT($leftresult,$rightresult);
2018             }
2019         }
2020         else {
2021 # this error is impossible, because of the regexp that isolate the operand, but just in case...
2022             return $leftresult;
2023         }
2024     }
2025     warn "string :" . $string if $DEBUG;
2026     my $left = "";
2027     my $right = "";
2028     my $operator = "";
2029     if ($string =~ /(.*?)( and | or | not | AND | OR | NOT )(.*)/) {
2030         $left     = $1;
2031         $right    = $3;
2032         $operator = lc($2);    # FIXME: and/or/not are operators, not operands
2033     }
2034     warn "no parenthesis. left : $left operator: $operator right: $right"
2035       if $DEBUG;
2036
2037     # it's not a leaf, we have a and/or/not
2038     if ($operator) {
2039
2040         # reintroduce comma content if needed
2041         $right =~ s/__X__/"$commacontent"/ if $commacontent;
2042         $left  =~ s/__X__/"$commacontent"/ if $commacontent;
2043         warn "node : $left / $operator / $right\n" if $DEBUG;
2044         my $leftresult  = NZanalyse( $left,  $server );
2045         my $rightresult = NZanalyse( $right, $server );
2046         warn " leftresult : $leftresult" if $DEBUG;
2047         warn " rightresult : $rightresult" if $DEBUG;
2048         # OK, we have the results for right and left part of the query
2049         # depending of operand, intersect, union or exclude both lists
2050         # to get a result list
2051         if ( $operator eq ' and ' ) {
2052             return NZoperatorAND($leftresult,$rightresult);
2053         }
2054         elsif ( $operator eq ' or ' ) {
2055
2056             # just merge the 2 strings
2057             return $leftresult . $rightresult;
2058         }
2059         elsif ( $operator eq ' not ' ) {
2060             return NZoperatorNOT($leftresult,$rightresult);
2061         }
2062         else {
2063
2064 # this error is impossible, because of the regexp that isolate the operand, but just in case...
2065             die "error : operand unknown : $operator for $string";
2066         }
2067
2068         # it's a leaf, do the real SQL query and return the result
2069     }
2070     else {
2071         $string =~ s/__X__/"$commacontent"/ if $commacontent;
2072         $string =~ s/-|\.|\?|,|;|!|'|\(|\)|\[|\]|{|}|"|&|\+|\*|\// /g;
2073         #remove trailing blank at the beginning
2074         $string =~ s/^ //g;
2075         warn "leaf:$string" if $DEBUG;
2076
2077         # parse the string in in operator/operand/value again
2078         my $left = "";
2079         my $operator = "";
2080         my $right = "";
2081         if ($string =~ /(.*)(>=|<=)(.*)/) {
2082             $left     = $1;
2083             $operator = $2;
2084             $right    = $3;
2085         } else {
2086             $left = $string;
2087         }
2088 #         warn "handling leaf... left:$left operator:$operator right:$right"
2089 #           if $DEBUG;
2090         unless ($operator) {
2091             if ($string =~ /(.*)(>|<|=)(.*)/) {
2092                 $left     = $1;
2093                 $operator = $2;
2094                 $right    = $3;
2095                 warn
2096     "handling unless (operator)... left:$left operator:$operator right:$right"
2097                 if $DEBUG;
2098             } else {
2099                 $left = $string;
2100             }
2101         }
2102         my $results;
2103
2104 # strip adv, zebra keywords, currently not handled in nozebra: wrdl, ext, phr...
2105         $left =~ s/ .*$//;
2106
2107         # automatic replace for short operators
2108         $left = 'title'            if $left =~ '^ti$';
2109         $left = 'author'           if $left =~ '^au$';
2110         $left = 'publisher'        if $left =~ '^pb$';
2111         $left = 'subject'          if $left =~ '^su$';
2112         $left = 'koha-Auth-Number' if $left =~ '^an$';
2113         $left = 'keyword'          if $left =~ '^kw$';
2114         $left = 'itemtype'         if $left =~ '^mc$'; # Fix for Bug 2599 - Search limits not working for NoZebra
2115         warn "handling leaf... left:$left operator:$operator right:$right" if $DEBUG;
2116         my $dbh = C4::Context->dbh;
2117         if ( $operator && $left ne 'keyword' ) {
2118             #do a specific search
2119             $operator = 'LIKE' if $operator eq '=' and $right =~ /%/;
2120             my $sth = $dbh->prepare(
2121 "SELECT biblionumbers,value FROM nozebra WHERE server=? AND indexname=? AND value $operator ?"
2122             );
2123             warn "$left / $operator / $right\n" if $DEBUG;
2124
2125             # split each word, query the DB and build the biblionumbers result
2126             #sanitizing leftpart
2127             $left =~ s/^\s+|\s+$//;
2128             foreach ( split / /, $right ) {
2129                 my $biblionumbers;
2130                 $_ =~ s/^\s+|\s+$//;
2131                 next unless $_;
2132                 warn "EXECUTE : $server, $left, $_" if $DEBUG;
2133                 $sth->execute( $server, $left, $_ )
2134                   or warn "execute failed: $!";
2135                 while ( my ( $line, $value ) = $sth->fetchrow ) {
2136
2137 # if we are dealing with a numeric value, use only numeric results (in case of >=, <=, > or <)
2138 # otherwise, fill the result
2139                     $biblionumbers .= $line
2140                       unless ( $right =~ /^\d+$/ && $value =~ /\D/ );
2141                     warn "result : $value "
2142                       . ( $right  =~ /\d/ ) . "=="
2143                       . ( $value =~ /\D/?$line:"" ) if $DEBUG;         #= $line";
2144                 }
2145
2146 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
2147                 if ($results) {
2148                     warn "NZAND" if $DEBUG;
2149                     $results = NZoperatorAND($biblionumbers,$results);
2150                 } else {
2151                     $results = $biblionumbers;
2152                 }
2153             }
2154         }
2155         else {
2156       #do a complete search (all indexes), if index='kw' do complete search too.
2157             my $sth = $dbh->prepare(
2158 "SELECT biblionumbers FROM nozebra WHERE server=? AND value LIKE ?"
2159             );
2160
2161             # split each word, query the DB and build the biblionumbers result
2162             foreach ( split / /, $string ) {
2163                 next if C4::Context->stopwords->{ uc($_) };   # skip if stopword
2164                 warn "search on all indexes on $_" if $DEBUG;
2165                 my $biblionumbers;
2166                 next unless $_;
2167                 $sth->execute( $server, $_ );
2168                 while ( my $line = $sth->fetchrow ) {
2169                     $biblionumbers .= $line;
2170                 }
2171
2172 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
2173                 if ($results) {
2174                     $results = NZoperatorAND($biblionumbers,$results);
2175                 }
2176                 else {
2177                     warn "NEW RES for $_ = $biblionumbers" if $DEBUG;
2178                     $results = $biblionumbers;
2179                 }
2180             }
2181         }
2182         warn "return : $results for LEAF : $string" if $DEBUG;
2183         return $results;
2184     }
2185     warn "---------\nLeave NZanalyse\n---------" if $DEBUG;
2186 }
2187
2188 sub NZoperatorAND{
2189     my ($rightresult, $leftresult)=@_;
2190
2191     my @leftresult = split /;/, $leftresult;
2192     warn " @leftresult / $rightresult \n" if $DEBUG;
2193
2194     #             my @rightresult = split /;/,$leftresult;
2195     my $finalresult;
2196
2197 # parse the left results, and if the biblionumber exist in the right result, save it in finalresult
2198 # the result is stored twice, to have the same weight for AND than OR.
2199 # example : TWO : 61,61,64,121 (two is twice in the biblio #61) / TOWER : 61,64,130
2200 # result : 61,61,61,61,64,64 for two AND tower : 61 has more weight than 64
2201     foreach (@leftresult) {
2202         my $value = $_;
2203         my $countvalue;
2204         ( $value, $countvalue ) = ( $1, $2 ) if ($value=~/(.*)-(\d+)$/);
2205         if ( $rightresult =~ /\Q$value\E-(\d+);/ ) {
2206             $countvalue = ( $1 > $countvalue ? $countvalue : $1 );
2207             $finalresult .=
2208                 "$value-$countvalue;$value-$countvalue;";
2209         }
2210     }
2211     warn "NZAND DONE : $finalresult \n" if $DEBUG;
2212     return $finalresult;
2213 }
2214
2215 sub NZoperatorOR{
2216     my ($rightresult, $leftresult)=@_;
2217     return $rightresult.$leftresult;
2218 }
2219
2220 sub NZoperatorNOT{
2221     my ($leftresult, $rightresult)=@_;
2222
2223     my @leftresult = split /;/, $leftresult;
2224
2225     #             my @rightresult = split /;/,$leftresult;
2226     my $finalresult;
2227     foreach (@leftresult) {
2228         my $value=$_;
2229         $value=$1 if $value=~m/(.*)-\d+$/;
2230         unless ($rightresult =~ "$value-") {
2231             $finalresult .= "$_;";
2232         }
2233     }
2234     return $finalresult;
2235 }
2236
2237 =head2 NZorder
2238
2239   $finalresult = NZorder($biblionumbers, $ordering,$results_per_page,$offset);
2240
2241   TODO :: Description
2242
2243 =cut
2244
2245 sub NZorder {
2246     my ( $biblionumbers, $ordering, $results_per_page, $offset ) = @_;
2247     warn "biblionumbers = $biblionumbers and ordering = $ordering\n" if $DEBUG;
2248
2249     # order title asc by default
2250     #     $ordering = '1=36 <i' unless $ordering;
2251     $results_per_page = 20 unless $results_per_page;
2252     $offset           = 0  unless $offset;
2253     my $dbh = C4::Context->dbh;
2254
2255     #
2256     # order by POPULARITY
2257     #
2258     if ( $ordering =~ /popularity/ ) {
2259         my %result;
2260         my %popularity;
2261
2262         # popularity is not in MARC record, it's builded from a specific query
2263         my $sth =
2264           $dbh->prepare("select sum(issues) from items where biblionumber=?");
2265         foreach ( split /;/, $biblionumbers ) {
2266             my ( $biblionumber, $title ) = split /,/, $_;
2267             $result{$biblionumber} = GetMarcBiblio($biblionumber);
2268             $sth->execute($biblionumber);
2269             my $popularity = $sth->fetchrow || 0;
2270
2271 # hint : the key is popularity.title because we can have
2272 # many results with the same popularity. In this case, sub-ordering is done by title
2273 # we also have biblionumber to avoid bug for 2 biblios with the same title & popularity
2274 # (un-frequent, I agree, but we won't forget anything that way ;-)
2275             $popularity{ sprintf( "%10d", $popularity ) . $title
2276                   . $biblionumber } = $biblionumber;
2277         }
2278
2279     # sort the hash and return the same structure as GetRecords (Zebra querying)
2280         my $result_hash;
2281         my $numbers = 0;
2282         if ( $ordering eq 'popularity_dsc' ) {    # sort popularity DESC
2283             foreach my $key ( sort { $b cmp $a } ( keys %popularity ) ) {
2284                 $result_hash->{'RECORDS'}[ $numbers++ ] =
2285                   $result{ $popularity{$key} }->as_usmarc();
2286             }
2287         }
2288         else {                                    # sort popularity ASC
2289             foreach my $key ( sort ( keys %popularity ) ) {
2290                 $result_hash->{'RECORDS'}[ $numbers++ ] =
2291                   $result{ $popularity{$key} }->as_usmarc();
2292             }
2293         }
2294         my $finalresult = ();
2295         $result_hash->{'hits'}         = $numbers;
2296         $finalresult->{'biblioserver'} = $result_hash;
2297         return $finalresult;
2298
2299         #
2300         # ORDER BY author
2301         #
2302     }
2303     elsif ( $ordering =~ /author/ ) {
2304         my %result;
2305         foreach ( split /;/, $biblionumbers ) {
2306             my ( $biblionumber, $title ) = split /,/, $_;
2307             my $record = GetMarcBiblio($biblionumber);
2308             my $author;
2309             if ( C4::Context->preference('marcflavour') eq 'UNIMARC' ) {
2310                 $author = $record->subfield( '200', 'f' );
2311                 $author = $record->subfield( '700', 'a' ) unless $author;
2312             }
2313             else {
2314                 $author = $record->subfield( '100', 'a' );
2315             }
2316
2317 # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
2318 # and we don't want to get only 1 result for each of them !!!
2319             $result{ $author . $biblionumber } = $record;
2320         }
2321
2322     # sort the hash and return the same structure as GetRecords (Zebra querying)
2323         my $result_hash;
2324         my $numbers = 0;
2325         if ( $ordering eq 'author_za' || $ordering eq 'author_dsc' ) {    # sort by author desc
2326             foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
2327                 $result_hash->{'RECORDS'}[ $numbers++ ] =
2328                   $result{$key}->as_usmarc();
2329             }
2330         }
2331         else {                               # sort by author ASC
2332             foreach my $key ( sort ( keys %result ) ) {
2333                 $result_hash->{'RECORDS'}[ $numbers++ ] =
2334                   $result{$key}->as_usmarc();
2335             }
2336         }
2337         my $finalresult = ();
2338         $result_hash->{'hits'}         = $numbers;
2339         $finalresult->{'biblioserver'} = $result_hash;
2340         return $finalresult;
2341
2342         #
2343         # ORDER BY callnumber
2344         #
2345     }
2346     elsif ( $ordering =~ /callnumber/ ) {
2347         my %result;
2348         foreach ( split /;/, $biblionumbers ) {
2349             my ( $biblionumber, $title ) = split /,/, $_;
2350             my $record = GetMarcBiblio($biblionumber);
2351             my $callnumber;
2352             my $frameworkcode = GetFrameworkCode($biblionumber);
2353             my ( $callnumber_tag, $callnumber_subfield ) = GetMarcFromKohaField(  'items.itemcallnumber', $frameworkcode);
2354                ( $callnumber_tag, $callnumber_subfield ) = GetMarcFromKohaField('biblioitems.callnumber', $frameworkcode)
2355                 unless $callnumber_tag;
2356             if ( C4::Context->preference('marcflavour') eq 'UNIMARC' ) {
2357                 $callnumber = $record->subfield( '200', 'f' );
2358             } else {
2359                 $callnumber = $record->subfield( '100', 'a' );
2360             }
2361
2362 # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
2363 # and we don't want to get only 1 result for each of them !!!
2364             $result{ $callnumber . $biblionumber } = $record;
2365         }
2366
2367     # sort the hash and return the same structure as GetRecords (Zebra querying)
2368         my $result_hash;
2369         my $numbers = 0;
2370         if ( $ordering eq 'call_number_dsc' ) {    # sort by title desc
2371             foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
2372                 $result_hash->{'RECORDS'}[ $numbers++ ] =
2373                   $result{$key}->as_usmarc();
2374             }
2375         }
2376         else {                                     # sort by title ASC
2377             foreach my $key ( sort { $a cmp $b } ( keys %result ) ) {
2378                 $result_hash->{'RECORDS'}[ $numbers++ ] =
2379                   $result{$key}->as_usmarc();
2380             }
2381         }
2382         my $finalresult = ();
2383         $result_hash->{'hits'}         = $numbers;
2384         $finalresult->{'biblioserver'} = $result_hash;
2385         return $finalresult;
2386     }
2387     elsif ( $ordering =~ /pubdate/ ) {             #pub year
2388         my %result;
2389         foreach ( split /;/, $biblionumbers ) {
2390             my ( $biblionumber, $title ) = split /,/, $_;
2391             my $record = GetMarcBiblio($biblionumber);
2392             my ( $publicationyear_tag, $publicationyear_subfield ) =
2393               GetMarcFromKohaField( 'biblioitems.publicationyear', '' );
2394             my $publicationyear =
2395               $record->subfield( $publicationyear_tag,
2396                 $publicationyear_subfield );
2397
2398 # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
2399 # and we don't want to get only 1 result for each of them !!!
2400             $result{ $publicationyear . $biblionumber } = $record;
2401         }
2402
2403     # sort the hash and return the same structure as GetRecords (Zebra querying)
2404         my $result_hash;
2405         my $numbers = 0;
2406         if ( $ordering eq 'pubdate_dsc' ) {    # sort by pubyear desc
2407             foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
2408                 $result_hash->{'RECORDS'}[ $numbers++ ] =
2409                   $result{$key}->as_usmarc();
2410             }
2411         }
2412         else {                                 # sort by pub year ASC
2413             foreach my $key ( sort ( keys %result ) ) {
2414                 $result_hash->{'RECORDS'}[ $numbers++ ] =
2415                   $result{$key}->as_usmarc();
2416             }
2417         }
2418         my $finalresult = ();
2419         $result_hash->{'hits'}         = $numbers;
2420         $finalresult->{'biblioserver'} = $result_hash;
2421         return $finalresult;
2422
2423         #
2424         # ORDER BY title
2425         #
2426     }
2427     elsif ( $ordering =~ /title/ ) {
2428
2429 # the title is in the biblionumbers string, so we just need to build a hash, sort it and return
2430         my %result;
2431         foreach ( split /;/, $biblionumbers ) {
2432             my ( $biblionumber, $title ) = split /,/, $_;
2433
2434 # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
2435 # and we don't want to get only 1 result for each of them !!!
2436 # hint & speed improvement : we can order without reading the record
2437 # so order, and read records only for the requested page !
2438             $result{ $title . $biblionumber } = $biblionumber;
2439         }
2440
2441     # sort the hash and return the same structure as GetRecords (Zebra querying)
2442         my $result_hash;
2443         my $numbers = 0;
2444         if ( $ordering eq 'title_az' ) {    # sort by title desc
2445             foreach my $key ( sort ( keys %result ) ) {
2446                 $result_hash->{'RECORDS'}[ $numbers++ ] = $result{$key};
2447             }
2448         }
2449         else {                              # sort by title ASC
2450             foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
2451                 $result_hash->{'RECORDS'}[ $numbers++ ] = $result{$key};
2452             }
2453         }
2454
2455         # limit the $results_per_page to result size if it's more
2456         $results_per_page = $numbers - 1 if $numbers < $results_per_page;
2457
2458         # for the requested page, replace biblionumber by the complete record
2459         # speed improvement : avoid reading too much things
2460         for (
2461             my $counter = $offset ;
2462             $counter <= $offset + $results_per_page ;
2463             $counter++
2464           )
2465         {
2466             $result_hash->{'RECORDS'}[$counter] =
2467               GetMarcBiblio( $result_hash->{'RECORDS'}[$counter] )->as_usmarc;
2468         }
2469         my $finalresult = ();
2470         $result_hash->{'hits'}         = $numbers;
2471         $finalresult->{'biblioserver'} = $result_hash;
2472         return $finalresult;
2473     }
2474     else {
2475
2476 #
2477 # order by ranking
2478 #
2479 # we need 2 hashes to order by ranking : the 1st one to count the ranking, the 2nd to order by ranking
2480         my %result;
2481         my %count_ranking;
2482         foreach ( split /;/, $biblionumbers ) {
2483             my ( $biblionumber, $title ) = split /,/, $_;
2484             $title =~ /(.*)-(\d)/;
2485
2486             # get weight
2487             my $ranking = $2;
2488
2489 # note that we + the ranking because ranking is calculated on weight of EACH term requested.
2490 # if we ask for "two towers", and "two" has weight 2 in biblio N, and "towers" has weight 4 in biblio N
2491 # biblio N has ranking = 6
2492             $count_ranking{$biblionumber} += $ranking;
2493         }
2494
2495 # build the result by "inverting" the count_ranking hash
2496 # 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
2497 #         warn "counting";
2498         foreach ( keys %count_ranking ) {
2499             $result{ sprintf( "%10d", $count_ranking{$_} ) . '-' . $_ } = $_;
2500         }
2501
2502     # sort the hash and return the same structure as GetRecords (Zebra querying)
2503         my $result_hash;
2504         my $numbers = 0;
2505         foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
2506             $result_hash->{'RECORDS'}[ $numbers++ ] = $result{$key};
2507         }
2508
2509         # limit the $results_per_page to result size if it's more
2510         $results_per_page = $numbers - 1 if $numbers < $results_per_page;
2511
2512         # for the requested page, replace biblionumber by the complete record
2513         # speed improvement : avoid reading too much things
2514         for (
2515             my $counter = $offset ;
2516             $counter <= $offset + $results_per_page ;
2517             $counter++
2518           )
2519         {
2520             $result_hash->{'RECORDS'}[$counter] =
2521               GetMarcBiblio( $result_hash->{'RECORDS'}[$counter] )->as_usmarc
2522               if $result_hash->{'RECORDS'}[$counter];
2523         }
2524         my $finalresult = ();
2525         $result_hash->{'hits'}         = $numbers;
2526         $finalresult->{'biblioserver'} = $result_hash;
2527         return $finalresult;
2528     }
2529 }
2530
2531 =head2 enabled_staff_search_views
2532
2533 %hash = enabled_staff_search_views()
2534
2535 This function returns a hash that contains three flags obtained from the system
2536 preferences, used to determine whether a particular staff search results view
2537 is enabled.
2538
2539 =over 2
2540
2541 =item C<Output arg:>
2542
2543     * $hash{can_view_MARC} is true only if the MARC view is enabled
2544     * $hash{can_view_ISBD} is true only if the ISBD view is enabled
2545     * $hash{can_view_labeledMARC} is true only if the Labeled MARC view is enabled
2546
2547 =item C<usage in the script:>
2548
2549 =back
2550
2551 $template->param ( C4::Search::enabled_staff_search_views );
2552
2553 =cut
2554
2555 sub enabled_staff_search_views
2556 {
2557         return (
2558                 can_view_MARC                   => C4::Context->preference('viewMARC'),                 # 1 if the staff search allows the MARC view
2559                 can_view_ISBD                   => C4::Context->preference('viewISBD'),                 # 1 if the staff search allows the ISBD view
2560                 can_view_labeledMARC    => C4::Context->preference('viewLabeledMARC'),  # 1 if the staff search allows the Labeled MARC view
2561         );
2562 }
2563
2564 sub AddSearchHistory{
2565         my ($borrowernumber,$session,$query_desc,$query_cgi, $total)=@_;
2566     my $dbh = C4::Context->dbh;
2567
2568     # Add the request the user just made
2569     my $sql = "INSERT INTO search_history(userid, sessionid, query_desc, query_cgi, total, time) VALUES(?, ?, ?, ?, ?, NOW())";
2570     my $sth   = $dbh->prepare($sql);
2571     $sth->execute($borrowernumber, $session, $query_desc, $query_cgi, $total);
2572         return $dbh->last_insert_id(undef, 'search_history', undef,undef,undef);
2573 }
2574
2575 sub GetSearchHistory{
2576         my ($borrowernumber,$session)=@_;
2577     my $dbh = C4::Context->dbh;
2578
2579     # Add the request the user just made
2580     my $query = "SELECT FROM search_history WHERE (userid=? OR sessionid=?)";
2581     my $sth   = $dbh->prepare($query);
2582         $sth->execute($borrowernumber, $session);
2583     return  $sth->fetchall_hashref({});
2584 }
2585
2586 =head2 z3950_search_args
2587
2588 $arrayref = z3950_search_args($matchpoints)
2589
2590 This function returns an array reference that contains the search parameters to be
2591 passed to the Z39.50 search script (z3950_search.pl). The array elements
2592 are hash refs whose keys are name, value and encvalue, and whose values are the
2593 name of a search parameter, the value of that search parameter and the URL encoded
2594 value of that parameter.
2595
2596 The search parameter names are lccn, isbn, issn, title, author, dewey and subject.
2597
2598 The search parameter values are obtained from the bibliographic record whose
2599 data is in a hash reference in $matchpoints, as returned by Biblio::GetBiblioData().
2600
2601 If $matchpoints is a scalar, it is assumed to be an unnamed query descriptor, e.g.
2602 a general purpose search argument. In this case, the returned array contains only
2603 entry: the key is 'title' and the value and encvalue are derived from $matchpoints.
2604
2605 If a search parameter value is undefined or empty, it is not included in the returned
2606 array.
2607
2608 The returned array reference may be passed directly to the template parameters.
2609
2610 =over 2
2611
2612 =item C<Output arg:>
2613
2614     * $array containing hash refs as described above
2615
2616 =item C<usage in the script:>
2617
2618 =back
2619
2620 $data = Biblio::GetBiblioData($bibno);
2621 $template->param ( MYLOOP => C4::Search::z3950_search_args($data) )
2622
2623 *OR*
2624
2625 $template->param ( MYLOOP => C4::Search::z3950_search_args($searchscalar) )
2626
2627 =cut
2628
2629 sub z3950_search_args {
2630     my $bibrec = shift;
2631     $bibrec = { title => $bibrec } if !ref $bibrec;
2632     my $array = [];
2633     for my $field (qw/ lccn isbn issn title author dewey subject /)
2634     {
2635         my $encvalue = URI::Escape::uri_escape_utf8($bibrec->{$field});
2636         push @$array, { name=>$field, value=>$bibrec->{$field}, encvalue=>$encvalue } if defined $bibrec->{$field};
2637     }
2638     return $array;
2639 }
2640
2641 =head2 BiblioAddAuthorities
2642
2643 ( $countlinked, $countcreated ) = BiblioAddAuthorities($record, $frameworkcode);
2644
2645 this function finds the authorities linked to the biblio
2646     * search in the authority DB for the same authid (in $9 of the biblio)
2647     * search in the authority DB for the same 001 (in $3 of the biblio in UNIMARC)
2648     * search in the authority DB for the same values (exactly) (in all subfields of the biblio)
2649 OR adds a new authority record
2650
2651 =over 2
2652
2653 =item C<input arg:>
2654
2655     * $record is the MARC record in question (marc blob)
2656     * $frameworkcode is the bibliographic framework to use (if it is "" it uses the default framework)
2657
2658 =item C<Output arg:>
2659
2660     * $countlinked is the number of authorities records that are linked to this authority
2661     * $countcreated
2662
2663 =item C<BUGS>
2664     * 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)
2665
2666 =back
2667
2668 =cut
2669
2670
2671 sub BiblioAddAuthorities{
2672   my ( $record, $frameworkcode ) = @_;
2673   my $dbh=C4::Context->dbh;
2674   my $query=$dbh->prepare(qq|
2675 SELECT authtypecode,tagfield
2676 FROM marc_subfield_structure
2677 WHERE frameworkcode=?
2678 AND (authtypecode IS NOT NULL AND authtypecode<>\"\")|);
2679 # SELECT authtypecode,tagfield
2680 # FROM marc_subfield_structure
2681 # WHERE frameworkcode=?
2682 # AND (authtypecode IS NOT NULL OR authtypecode<>\"\")|);
2683   $query->execute($frameworkcode);
2684   my ($countcreated,$countlinked);
2685   while (my $data=$query->fetchrow_hashref){
2686     foreach my $field ($record->field($data->{tagfield})){
2687       next if ($field->subfield('3')||$field->subfield('9'));
2688       # No authorities id in the tag.
2689       # Search if there is any authorities to link to.
2690       my $query='at='.$data->{authtypecode}.' ';
2691       map {$query.= ' and he,ext="'.$_->[1].'"' if ($_->[0]=~/[A-z]/)}  $field->subfields();
2692       my ($error, $results, $total_hits)=SimpleSearch( $query, undef, undef, [ "authorityserver" ] );
2693     # there is only 1 result
2694           if ( $error ) {
2695         warn "BIBLIOADDSAUTHORITIES: $error";
2696             return (0,0) ;
2697           }
2698       if ( @{$results} == 1 ) {
2699         my $marcrecord = MARC::File::USMARC::decode($results->[0]);
2700         $field->add_subfields('9'=>$marcrecord->field('001')->data);
2701         $countlinked++;
2702       } elsif ( @{$results} > 1 ) {
2703    #More than One result
2704    #This can comes out of a lack of a subfield.
2705 #         my $marcrecord = MARC::File::USMARC::decode($results->[0]);
2706 #         $record->field($data->{tagfield})->add_subfields('9'=>$marcrecord->field('001')->data);
2707   $countlinked++;
2708       } else {
2709   #There are no results, build authority record, add it to Authorities, get authid and add it to 9
2710   ###NOTICE : This is only valid if a subfield is linked to one and only one authtypecode
2711   ###NOTICE : This can be a problem. We should also look into other types and rejected forms.
2712          my $authtypedata=C4::AuthoritiesMarc::GetAuthType($data->{authtypecode});
2713          next unless $authtypedata;
2714          my $marcrecordauth=MARC::Record->new();
2715          my $authfield=MARC::Field->new($authtypedata->{auth_tag_to_report},'','',"a"=>"".$field->subfield('a'));
2716          map { $authfield->add_subfields($_->[0]=>$_->[1]) if ($_->[0]=~/[A-z]/ && $_->[0] ne "a" )}  $field->subfields();
2717          $marcrecordauth->insert_fields_ordered($authfield);
2718
2719          # bug 2317: ensure new authority knows it's using UTF-8; currently
2720          # only need to do this for MARC21, as MARC::Record->as_xml_record() handles
2721          # automatically for UNIMARC (by not transcoding)
2722          # FIXME: AddAuthority() instead should simply explicitly require that the MARC::Record
2723          # use UTF-8, but as of 2008-08-05, did not want to introduce that kind
2724          # of change to a core API just before the 3.0 release.
2725          if (C4::Context->preference('marcflavour') eq 'MARC21') {
2726             SetMarcUnicodeFlag($marcrecordauth, 'MARC21');
2727          }
2728
2729 #          warn "AUTH RECORD ADDED : ".$marcrecordauth->as_formatted;
2730
2731          my $authid=AddAuthority($marcrecordauth,'',$data->{authtypecode});
2732          $countcreated++;
2733          $field->add_subfields('9'=>$authid);
2734       }
2735     }
2736   }
2737   return ($countlinked,$countcreated);
2738 }
2739
2740 =head2 GetDistinctValues($field);
2741
2742 C<$field> is a reference to the fields array
2743
2744 =cut
2745
2746 sub GetDistinctValues {
2747     my ($fieldname,$string)=@_;
2748     # returns a reference to a hash of references to branches...
2749     if ($fieldname=~/\./){
2750                         my ($table,$column)=split /\./, $fieldname;
2751                         my $dbh = C4::Context->dbh;
2752                         warn "select DISTINCT($column) as value, count(*) as cnt from $table group by lib order by $column " if $DEBUG;
2753                         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 ");
2754                         $sth->execute;
2755                         my $elements=$sth->fetchall_arrayref({});
2756                         return $elements;
2757    }
2758    else {
2759                 $string||= qq("");
2760                 my @servers=qw<biblioserver authorityserver>;
2761                 my (@zconns,@results);
2762         for ( my $i = 0 ; $i < @servers ; $i++ ) {
2763                 $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
2764                         $results[$i] =
2765                       $zconns[$i]->scan(
2766                         ZOOM::Query::CCL2RPN->new( qq"$fieldname $string", $zconns[$i])
2767                       );
2768                 }
2769                 # The big moment: asynchronously retrieve results from all servers
2770                 my @elements;
2771                 while ( ( my $i = ZOOM::event( \@zconns ) ) != 0 ) {
2772                         my $ev = $zconns[ $i - 1 ]->last_event();
2773                         if ( $ev == ZOOM::Event::ZEND ) {
2774                                 next unless $results[ $i - 1 ];
2775                                 my $size = $results[ $i - 1 ]->size();
2776                                 if ( $size > 0 ) {
2777                       for (my $j=0;$j<$size;$j++){
2778                                                 my %hashscan;
2779                                                 @hashscan{qw(value cnt)}=$results[ $i - 1 ]->display_term($j);
2780                                                 push @elements, \%hashscan;
2781                                           }
2782                                 }
2783                         }
2784                 }
2785                 return \@elements;
2786    }
2787 }
2788
2789
2790 END { }    # module clean-up code here (global destructor)
2791
2792 1;
2793 __END__
2794
2795 =head1 AUTHOR
2796
2797 Koha Development Team <http://koha-community.org/>
2798
2799 =cut