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