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