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