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