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