C4/Search.pm

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