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