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