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         next unless  $results[ $i - 1 ];
 407             my $size = $results[ $i - 1 ]->size();
 408             if ( $size > 0 ) {
 409                 my $results_hash;
 410                 #$results_hash->{'server'} = $servers[$i-1];
 411                 # loop through the results
 412                 $results_hash->{'hits'} = $size;
 413                 my $times;
 414                 if ( $offset + $results_per_page <= $size ) {
 415                     $times = $offset + $results_per_page;
 416                 }
 417                 else {
 418                     $times = $size;
 419                 }
 420                 for ( my $j = $offset ; $j < $times ; $j++ )
 421                 {   #(($offset+$count<=$size) ? ($offset+$count):$size) ; $j++){
 422                     my $records_hash;
 423                     my $record;
 424                     my $facet_record;
 425                     ## This is just an index scan
 426                     if ($scan) {
 427                         my ( $term, $occ ) = $results[ $i - 1 ]->term($j);
 428                  # here we create a minimal MARC record and hand it off to the
 429                  # template just like a normal result ... perhaps not ideal, but
 430                  # it works for now
 431                         my $tmprecord = MARC::Record->new();
 432                         $tmprecord->encoding('UTF-8');
 433                         my $tmptitle;
 434                         my $tmpauthor;
 435                 # the minimal record in author/title (depending on MARC flavour)
 436                         if ( C4::Context->preference("marcflavour") eq
 437                             "UNIMARC" )
 438                         {
 439                             $tmptitle = MARC::Field->new(
 440                                 '200', ' ', ' ',
 441                                 a => $term,
 442                                 f => $occ
 443                             );
 444                         }
 445                         else {
 446                             $tmptitle = MARC::Field->new('245', ' ', ' ',a => $term,);
 447                             $tmpauthor = MARC::Field->new('100', ' ', ' ',a => $occ,);
 448                         }
 449                         $tmprecord->append_fields($tmptitle);
 450                         $tmprecord->append_fields($tmpauthor);
 451                         $results_hash->{'RECORDS'}[$j] = $tmprecord->as_usmarc();
 452                     }
 453                     else {
 454                         $record = $results[ $i - 1 ]->record($j)->raw();
 455
 456                         #warn "RECORD $j:".$record;
 457                         $results_hash->{'RECORDS'}[$j] =
 458                           $record;    # making a reference to a hash
 459                                       # Fill the facets while we're looping
 460                         $facet_record = MARC::Record->new_from_usmarc($record);
 461
 462                         #warn $servers[$i-1].$facet_record->title();
 463                         for ( my $k = 0 ; $k <= @$facets ; $k++ ) {
 464                             if ( $facets->[$k] ) {
 465                                 my @fields;
 466                                 for my $tag ( @{ $facets->[$k]->{'tags'} } ) {
 467                                     push @fields, $facet_record->field($tag);
 468                                 }
 469                                 for my $field (@fields) {
 470                                     my @subfields = $field->subfields();
 471                                     for my $subfield (@subfields) {
 472                                         my ( $code, $data ) = @$subfield;
 473                                         if ( $code eq
 474                                             $facets->[$k]->{'subfield'} )
 475                                         {
 476                                             $facets_counter->{ $facets->[$k]
 477                                                   ->{'link_value'} }->{$data}++;
 478                                         }
 479                                     }
 480                                 }
 481                                 $facets_info->{ $facets->[$k]->{'link_value'} }
 482                                   ->{'label_value'} =
 483                                   $facets->[$k]->{'label_value'};
 484                                 $facets_info->{ $facets->[$k]->{'link_value'} }
 485                                   ->{'expanded'} = $facets->[$k]->{'expanded'};
 486                             }
 487                         }
 488                     }
 489                 }
 490                 $results_hashref->{ $servers[ $i - 1 ] } = $results_hash;
 491             }
 492
 493             #print "connection ", $i-1, ": $size hits";
 494             #print $results[$i-1]->record(0)->render() if $size > 0;
 495             # BUILD FACETS
 496             for my $link_value (
 497                 sort { $facets_counter->{$b} <=> $facets_counter->{$a} }
 498                 keys %$facets_counter
 499               )
 500             {
 501                 my $expandable;
 502                 my $number_of_facets;
 503                 my @this_facets_array;
 504                 for my $one_facet (
 505                     sort {
 506                         $facets_counter->{$link_value}
 507                           ->{$b} <=> $facets_counter->{$link_value}->{$a}
 508                     } keys %{ $facets_counter->{$link_value} }
 509                   )
 510                 {
 511                     $number_of_facets++;
 512                     if (   ( $number_of_facets < 6 )
 513                         || ( $expanded_facet eq $link_value )
 514                         || ( $facets_info->{$link_value}->{'expanded'} ) )
 515                     {
 516
 517                        # sanitize the link value ), ( will cause errors with CCL
 518                         my $facet_link_value = $one_facet;
 519                         $facet_link_value =~ s/(\(|\))/ /g;
 520
 521                         # fix the length that will display in the label
 522                         my $facet_label_value = $one_facet;
 523                         $facet_label_value = substr( $one_facet, 0, 20 ) . "..."
 524                           unless length($facet_label_value) <= 20;
 525
 526                        # well, if it's a branch, label by the name, not the code
 527                         if ( $link_value =~ /branch/ ) {
 528                             $facet_label_value =
 529                               $branches->{$one_facet}->{'branchname'};
 530                         }
 531
 532                  # but we're down with the whole label being in the link's title
 533                         my $facet_title_value = $one_facet;
 534
 535                         push @this_facets_array,
 536                           (
 537                             {
 538                                 facet_count =>
 539                                   $facets_counter->{$link_value}->{$one_facet},
 540                                 facet_label_value => $facet_label_value,
 541                                 facet_title_value => $facet_title_value,
 542                                 facet_link_value  => $facet_link_value,
 543                                 type_link_value   => $link_value,
 544                             },
 545                           );
 546                     }
 547                 }
 548                 unless ( $facets_info->{$link_value}->{'expanded'} ) {
 549                     $expandable = 1
 550                       if ( ( $number_of_facets > 6 )
 551                         && ( $expanded_facet ne $link_value ) );
 552                 }
 553                 push @facets_loop,
 554                   (
 555                     {
 556                         type_link_value => $link_value,
 557                         type_id         => $link_value . "_id",
 558                         type_label      =>
 559                           $facets_info->{$link_value}->{'label_value'},
 560                         facets     => \@this_facets_array,
 561                         expandable => $expandable,
 562                         expand     => $link_value,
 563                     }
 564                   );
 565             }
 566         }
 567     }
 568     return ( undef, $results_hashref, \@facets_loop );
 569 }
 570
 571 # STOPWORDS
 572 sub _remove_stopwords {
 573     my ($operand,$index) = @_;
 574     my @stopwords_removed;
 575     # phrase and exact-qualified indexes shouldn't have stopwords removed
 576     if ($index!~m/phr|ext/){
 577     # remove stopwords from operand : parse all stopwords & remove them (case insensitive)
 578     #       we use IsAlpha unicode definition, to deal correctly with diacritics.
 579     #       otherwise, a French word like "leçon" woudl be split into "le" "çon", le
 580     #       is an empty word, we'd get "çon" and wouldn't find anything...
 581         foreach (keys %{C4::Context->stopwords}) {
 582             next if ($_ =~/(and|or|not)/); # don't remove operators
 583             if ($operand =~ /(\P{IsAlpha}$_\P{IsAlpha}|^$_\P{IsAlpha}|\P{IsAlpha}$_$)/) {
 584                 $operand=~ s/\P{IsAlpha}$_\P{IsAlpha}/ /gi;
 585                 $operand=~ s/^$_\P{IsAlpha}/ /gi;
 586                 $operand=~ s/\P{IsAlpha}$_$/ /gi;
 587                 push @stopwords_removed, $_;
 588             }
 589         }
 590     }
 591     return ($operand, \@stopwords_removed);
 592 }
 593
 594 # TRUNCATION
 595 sub _detect_truncation {
 596     my ($operand,$index) = @_;
 597     my (@nontruncated,@righttruncated,@lefttruncated,@rightlefttruncated,@regexpr);
 598     $operand =~s/^ //g;
 599     my @wordlist= split (/\s/,$operand);
 600     foreach my $word (@wordlist){
 601         if ($word=~s/^\*([^\*]+)\*$/$1/){
 602             push @rightlefttruncated,$word;
 603         }
 604         elsif($word=~s/^\*([^\*]+)$/$1/){
 605             push @lefttruncated,$word;
 606         }
 607         elsif ($word=~s/^([^\*]+)\*$/$1/){
 608             push @righttruncated,$word;
 609         }
 610         elsif (index($word,"*")<0){
 611             push @nontruncated,$word;
 612         }
 613         else {
 614             push @regexpr,$word;
 615         }
 616     }
 617     return (\@nontruncated,\@righttruncated,\@lefttruncated,\@rightlefttruncated,\@regexpr);
 618 }
 619
 620 sub _build_stemmed_operand {
 621     my ($operand) = @_;
 622     my $stemmed_operand;
 623     # FIXME: the locale should be set based on the user's language and/or search choice
 624     my $stemmer = Lingua::Stem->new( -locale => 'EN-US' );
 625     # FIXME: these should be stored in the db so the librarian can modify the behavior
 626     $stemmer->add_exceptions(
 627             {
 628                 'and' => 'and',
 629                 'or'  => 'or',
 630                 'not' => 'not',
 631             }
 632
 633         );
 634     my @words = split( / /, $operand );
 635     my $stems = $stemmer->stem(@words);
 636     for my $stem (@$stems) {
 637             $stemmed_operand .= "$stem";
 638             $stemmed_operand .= "?" unless ( $stem =~ /(and$|or$|not$)/ ) || ( length($stem) < 3 );
 639             $stemmed_operand .= " ";
 640     }
 641     #warn "STEMMED OPERAND: $stemmed_operand";
 642     return $stemmed_operand;
 643 }
 644
 645 sub _build_weighted_query {
 646     # FIELD WEIGHTING - This is largely experimental stuff. What I'm committing works
 647     # pretty well but will work much better when we have an actual query parser
 648     my ($operand,$stemmed_operand,$index) = @_;
 649     my $stemming      = C4::Context->preference("QueryStemming")     || 0;
 650     my $weight_fields = C4::Context->preference("QueryWeightFields") || 0;
 651     my $fuzzy_enabled = C4::Context->preference("QueryFuzzy") || 0;
 652
 653     my $weighted_query .= "(rk=(";     # Specifies that we're applying rank
 654
 655     # Keyword, or, no index specified
 656     if ( ( $index eq 'kw' ) || ( !$index ) ) {
 657         $weighted_query .= "Title-cover,ext,r1=\"$operand\"";       # exact title-cover
 658         $weighted_query .= " or ti,ext,r2=\"$operand\"";            # exact title
 659         $weighted_query .= " or ti,phr,r3=\"$operand\"";            # phrase title
 660        #$weighted_query .= " or any,ext,r4=$operand";               # exact any
 661        #$weighted_query .=" or kw,wrdl,r5=\"$operand\"";            # word list any
 662         $weighted_query .= " or wrdl,fuzzy,r8=\"$operand\"" if $fuzzy_enabled; # add fuzzy, word list
 663         $weighted_query .= " or wrdl,right-Truncation,r9=\"$stemmed_operand\"" if ($stemming and $stemmed_operand); # add stemming, right truncation
 664     $weighted_query .= " or wrdl,r9=\"$operand\"";
 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     $query .=" ".$limit;
 938
 939     warn "query=$query and limit=$limit" if $DEBUG;
 940
 941     warn "QUERY:".$query if $DEBUG;
 942     warn "QUERY CGI:".$query_cgi if $DEBUG;
 943     warn "QUERY DESC:".$query_desc if $DEBUG;
 944     warn "LIMIT:".$limit if $DEBUG;
 945     warn "LIMIT CGI:".$limit_cgi if $DEBUG;
 946     warn "LIMIT DESC:".$limit_desc if $DEBUG;
 947     warn "---------" if $DEBUG;
 948     warn "Leave buildQuery" if $DEBUG;
 949     warn "---------" if $DEBUG;
 950     return ( undef, $query,$simple_query,$query_cgi,$query_desc,$limit,$limit_cgi,$limit_desc,$stopwords_removed,$query_type );
 951 }
 952
 953 # IMO this subroutine is pretty messy still -- it's responsible for
 954 # building the HTML output for the template
 955 sub searchResults {
 956     my ( $searchdesc, $hits, $results_per_page, $offset, @marcresults ) = @_;
 957     my $dbh = C4::Context->dbh;
 958     my $toggle;
 959     my $even = 1;
 960     my @newresults;
 961     my $span_terms_hashref;
 962     for my $span_term ( split( / /, $searchdesc ) ) {
 963         $span_term =~ s/(.*=|\)|\(|\+|\.|\*)//g;
 964         $span_terms_hashref->{$span_term}++;
 965     }
 966
 967     #Build branchnames hash
 968     #find branchname
 969     #get branch information.....
 970     my %branches;
 971     my $bsth =
 972       $dbh->prepare("SELECT branchcode,branchname FROM branches")
 973       ;    # FIXME : use C4::Koha::GetBranches
 974     $bsth->execute();
 975     while ( my $bdata = $bsth->fetchrow_hashref ) {
 976         $branches{ $bdata->{'branchcode'} } = $bdata->{'branchname'};
 977     }
 978     my %locations;
 979     my $lsch = $dbh->prepare("SELECT authorised_value,lib FROM authorised_values WHERE category = 'SHELF_LOC'");
 980     $lsch->execute();
 981     while (my $ldata = $lsch->fetchrow_hashref ) {
 982         $locations{ $ldata->{'authorised_value'} } = $ldata->{'lib'};
 983     }
 984
 985     #Build itemtype hash
 986     #find itemtype & itemtype image
 987     my %itemtypes;
 988     $bsth =
 989       $dbh->prepare("SELECT itemtype,description,imageurl,summary,notforloan FROM itemtypes");
 990     $bsth->execute();
 991     while ( my $bdata = $bsth->fetchrow_hashref ) {
 992         $itemtypes{ $bdata->{'itemtype'} }->{description} =
 993           $bdata->{'description'};
 994         $itemtypes{ $bdata->{'itemtype'} }->{imageurl} = $bdata->{'imageurl'};
 995         $itemtypes{ $bdata->{'itemtype'} }->{summary} = $bdata->{'summary'};
 996         $itemtypes{ $bdata->{'itemtype'} }->{notforloan} = $bdata->{'notforloan'};
 997     }
 998
 999     #search item field code
1000     my $sth = $dbh->prepare("SELECT tagfield FROM marc_subfield_structure WHERE kohafield LIKE 'items.itemnumber'");
1001     $sth->execute;
1002     my ($itemtag) = $sth->fetchrow;
1003
1004     ## find column names of items related to MARC
1005     my $sth2 = $dbh->prepare("SHOW COLUMNS FROM items");
1006     $sth2->execute;
1007     my %subfieldstosearch;
1008     while ( ( my $column ) = $sth2->fetchrow ) {
1009         my ( $tagfield, $tagsubfield ) =
1010           &GetMarcFromKohaField( "items." . $column, "" );
1011         $subfieldstosearch{$column} = $tagsubfield;
1012     }
1013     my $times;
1014
1015     if ( $hits && $offset + $results_per_page <= $hits ) {
1016         $times = $offset + $results_per_page;
1017     }
1018     else {
1019         $times = $hits;
1020     }
1021
1022     for ( my $i = $offset ; $i <= $times - 1 ; $i++ ) {
1023         my $marcrecord;
1024         $marcrecord = MARC::File::USMARC::decode( $marcresults[$i] );
1025         my $oldbiblio = TransformMarcToKoha( $dbh, $marcrecord, '' );
1026         $oldbiblio->{result_number} = $i+1;
1027         # add image url if there is one
1028         if ( $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} =~ /^http:/ ) {
1029             $oldbiblio->{imageurl} =
1030               $itemtypes{ $oldbiblio->{itemtype} }->{imageurl};
1031             $oldbiblio->{description} =
1032               $itemtypes{ $oldbiblio->{itemtype} }->{description};
1033         }
1034         else {
1035             $oldbiblio->{imageurl} =
1036               getitemtypeimagesrc() . "/"
1037               . $itemtypes{ $oldbiblio->{itemtype} }->{imageurl}
1038               if ( $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} );
1039             $oldbiblio->{description} =
1040               $itemtypes{ $oldbiblio->{itemtype} }->{description};
1041         }
1042         #
1043         # build summary if there is one (the summary is defined in itemtypes table
1044         #
1045         if ($itemtypes{ $oldbiblio->{itemtype} }->{summary}) {
1046             my $summary = $itemtypes{ $oldbiblio->{itemtype} }->{summary};
1047             my @fields = $marcrecord->fields();
1048             foreach my $field (@fields) {
1049                 my $tag = $field->tag();
1050                 my $tagvalue = $field->as_string();
1051                 $summary =~ s/\[(.?.?.?.?)$tag\*(.*?)]/$1$tagvalue$2\[$1$tag$2]/g;
1052                 unless ($tag<10) {
1053                     my @subf = $field->subfields;
1054                     for my $i (0..$#subf) {
1055                         my $subfieldcode = $subf[$i][0];
1056                         my $subfieldvalue = $subf[$i][1];
1057                         my $tagsubf = $tag.$subfieldcode;
1058                         $summary =~ s/\[(.?.?.?.?)$tagsubf(.*?)]/$1$subfieldvalue$2\[$1$tagsubf$2]/g;
1059                     }
1060                 }
1061             }
1062             $summary =~ s/\[(.*?)]//g;
1063             $summary =~ s/\n/<br>/g;
1064             $oldbiblio->{summary} = $summary;
1065         }
1066         # add spans to search term in results for search term highlighting
1067         my $searchhighlightblob;
1068         for my $highlight_field ($marcrecord->fields) {
1069             next if $highlight_field->tag() =~ /(^00)/; # skip fixed fields
1070             my $match;
1071             my $field = $highlight_field->as_string();
1072             for my $term ( keys %$span_terms_hashref ) {
1073                 if (($field =~ /$term/i) && (length($term) > 3)) {
1074                     $field =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1075                     $match++;
1076                 }
1077             }
1078             $searchhighlightblob .= $field." ... " if $match;
1079         }
1080         $oldbiblio->{'searchhighlightblob'} = $searchhighlightblob;
1081     # save an author with no <span> tag, for the <a href=search.pl?q=<!--tmpl_var name="author"-->> link
1082         $oldbiblio->{'author_nospan'} = $oldbiblio->{'author'};
1083         for my $term ( keys %$span_terms_hashref ) {
1084             my $old_term = $term;
1085             if ( length($term) > 3 ) {
1086                 $term =~ s/(.*=|\)|\(|\+|\.|\?|\[|\]|\\|\*)//g;
1087                 $oldbiblio->{'title'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1088                 $oldbiblio->{'subtitle'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1089                 $oldbiblio->{'author'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1090                 $oldbiblio->{'publishercode'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1091                 $oldbiblio->{'place'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1092                 $oldbiblio->{'pages'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1093                 $oldbiblio->{'notes'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1094                 $oldbiblio->{'size'}  =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1095             }
1096         }
1097
1098         if ( $i % 2 ) {
1099             $toggle = "#ffffcc";
1100         }
1101         else {
1102             $toggle = "white";
1103         }
1104         $oldbiblio->{'toggle'} = $toggle;
1105         my @fields = $marcrecord->field($itemtag);
1106
1107 # Setting item statuses for display
1108         my @available_items_loop;
1109         my @onloan_items_loop;
1110         my @other_items_loop;
1111
1112         my $available_items;
1113         my $onloan_items;
1114         my $other_items;
1115
1116         my $ordered_count     = 0;
1117         my $available_count   = 0;
1118         my $onloan_count      = 0;
1119         my $longoverdue_count = 0;
1120         my $other_count       = 0;
1121         my $wthdrawn_count    = 0;
1122         my $itemlost_count    = 0;
1123         my $itembinding_count = 0;
1124         my $itemdamaged_count = 0;
1125         my $can_place_holds   = 0;
1126         my $items_count=scalar(@fields);
1127         my $items_counter;
1128         my $maxitems = (C4::Context->preference('maxItemsinSearchResults')) ? C4::Context->preference('maxItemsinSearchResults')- 1 : 1;
1129         foreach my $field (@fields) {
1130             my $item;
1131             $items_counter++;
1132
1133             # populate the items hash
1134             foreach my $code ( keys %subfieldstosearch ) {
1135                 $item->{$code} = $field->subfield( $subfieldstosearch{$code} );
1136             }
1137
1138             # set item's branch name, use homebranch first, fall back to holdingbranch
1139             if ($item->{'homebranch'}) {
1140                     $item->{'branchname'} = $branches{$item->{homebranch}};
1141             }
1142             # Last resort
1143             elsif ($item->{'holdingbranch'}) {
1144                      $item->{'branchname'} = $branches{$item->{holdingbranch}};
1145             }
1146             # key for items results is built from branchcode . coded location qualifier . itemcallnumber
1147             if ($item->{onloan}) {
1148                 $onloan_count++;
1149                 $onloan_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{due_date} }->{due_date} = format_date($item->{onloan});
1150                 $onloan_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{due_date} }->{count}++ if $item->{'homebranch'};
1151                 $onloan_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{due_date} }->{branchname} = $item->{'branchname'};
1152                 $onloan_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{due_date} }->{location} =  $locations{$item->{location}};
1153                 $onloan_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{due_date} }->{itemcallnumber} = $item->{itemcallnumber};
1154
1155                 # if something's checked out and lost, mark it as 'long overdue'
1156                 if ( $item->{itemlost} ) {
1157                     $onloan_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{due_date} }->{longoverdue}++;
1158                     $longoverdue_count++;
1159                 }
1160                 # can place holds as long as this item isn't lost
1161                 else {
1162                     $can_place_holds = 1;
1163                 }
1164             }
1165
1166             # items not on loan, but still unavailable ( lost, withdrawn, damaged )
1167             else {
1168                 # item is on order
1169                 if ( $item->{notforloan} == -1) {
1170                     $ordered_count++;
1171                 }
1172
1173                 # item is withdrawn, lost or damaged
1174                 if ( $item->{wthdrawn} || $item->{itemlost} || $item->{damaged} ) {
1175                     $wthdrawn_count++ if $item->{wthdrawn};
1176                     $itemlost_count++ if $item->{itemlost};
1177                     $itemdamaged_count++ if $item->{damaged};
1178                     $item->{status} = $item->{wthdrawn}."-".$item->{itemlost}."-".$item->{damaged};
1179                     $other_count++;
1180                     $other_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{status} }->{wthdrawn} = $item->{wthdrawn};
1181                     $other_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{status} }->{itemlost} = $item->{itemlost};
1182                     $other_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{status} }->{damaged} = $item->{damaged};
1183                     $other_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{status} }->{count}++ if $item->{'homebranch'};
1184                     $other_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{status} }->{branchname} = $item->{'branchname'};
1185                     $other_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{status} }->{location} =  $locations{$item->{location}};
1186                     $other_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'}.$item->{status} }->{itemcallnumber} = $item->{itemcallnumber};
1187                 }
1188
1189                 # item is available
1190                 else {
1191                     $can_place_holds = 1;
1192                     $available_count++;
1193                     $available_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'} }->{count}++ if $item->{'homebranch'};
1194                     $available_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'} }->{branchname} = $item->{'branchname'};
1195                     $available_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'} }->{location} =  $locations{$item->{location}};
1196                     $available_items->{ $item->{'homebranch'}.'--'.$item->{location}.$item->{'itemcallnumber'} }->{itemcallnumber} = $item->{itemcallnumber};
1197                 }
1198             }
1199         } # notforloan, item level and biblioitem level
1200         my ($availableitemscount, $onloanitemscount, $otheritemscount);
1201         my $maxitems = (C4::Context->preference('maxItemsinSearchResults')) ? C4::Context->preference('maxItemsinSearchResults')- 1 : 1;
1202         for my $key ( sort keys %$onloan_items ) {
1203             $onloanitemscount++;
1204             push @onloan_items_loop, $onloan_items->{$key} unless $onloanitemscount > $maxitems;
1205         }
1206         for my $key ( sort keys %$other_items ) {
1207             $otheritemscount++;
1208             push @other_items_loop, $other_items->{$key} unless $otheritemscount > $maxitems;
1209         }
1210         for my $key ( sort keys %$available_items ) {
1211             $availableitemscount++;
1212             push @available_items_loop, $available_items->{$key} unless $availableitemscount > $maxitems;
1213         }
1214         # last check for norequest : if itemtype is notforloan, it can't be reserved either, whatever the items
1215         $can_place_holds = 0 if $itemtypes{$oldbiblio->{itemtype}}->{notforloan};
1216         $oldbiblio->{norequests}    = 1 unless $can_place_holds;
1217         $oldbiblio->{itemsplural} = 1 if $items_count>1;
1218         $oldbiblio->{items_count}    = $items_count;
1219         $oldbiblio->{available_items_loop}    = \@available_items_loop;
1220         $oldbiblio->{onloan_items_loop} = \@onloan_items_loop;
1221         $oldbiblio->{other_items_loop} = \@other_items_loop;
1222         $oldbiblio->{availablecount} = $available_count;
1223         $oldbiblio->{availableplural} = 1 if $available_count>1;
1224         $oldbiblio->{onloancount}   = $onloan_count;
1225         $oldbiblio->{onloanplural} = 1 if $onloan_count>1;
1226         $oldbiblio->{othercount}   = $other_count;
1227         $oldbiblio->{otherplural} = 1 if $other_count>1;
1228         $oldbiblio->{wthdrawncount} = $wthdrawn_count;
1229         $oldbiblio->{itemlostcount} = $itemlost_count;
1230         $oldbiblio->{damagedcount} = $itemdamaged_count;
1231         $oldbiblio->{orderedcount}  = $ordered_count;
1232         $oldbiblio->{isbn}          =~ s/-//g; # deleting - in isbn to enable amazon content
1233         push( @newresults, $oldbiblio );
1234     }
1235     return @newresults;
1236 }
1237
1238
1239
1240 #----------------------------------------------------------------------
1241 #
1242 # Non-Zebra GetRecords#
1243 #----------------------------------------------------------------------
1244
1245 =head2 NZgetRecords
1246
1247   NZgetRecords has the same API as zera getRecords, even if some parameters are not managed
1248
1249 =cut
1250 sub NZgetRecords {
1251     my ($query,$simple_query,$sort_by_ref,$servers_ref,$results_per_page,$offset,$expanded_facet,$branches,$query_type,$scan) = @_;
1252     warn "query =$query" if $DEBUG;
1253     my $result = NZanalyse($query);
1254     warn "results =$result" if $DEBUG;
1255     return (undef,NZorder($result,@$sort_by_ref[0],$results_per_page,$offset),undef);
1256 }
1257
1258 =head2 NZanalyse
1259
1260   NZanalyse : get a CQL string as parameter, and returns a list of biblionumber;title,biblionumber;title,...
1261   the list is built from an inverted index in the nozebra SQL table
1262   note that title is here only for convenience : the sorting will be very fast when requested on title
1263   if the sorting is requested on something else, we will have to reread all results, and that may be longer.
1264
1265 =cut
1266
1267 sub NZanalyse {
1268     my ($string,$server) = @_;
1269     warn "---------" if $DEBUG;
1270     warn "Enter NZanalyse" if $DEBUG;
1271     warn "---------" if $DEBUG;
1272
1273     # $server contains biblioserver or authorities, depending on what we search on.
1274     #warn "querying : $string on $server";
1275     $server='biblioserver' unless $server;
1276
1277     # if we have a ", replace the content to discard temporarily any and/or/not inside
1278     my $commacontent;
1279     if ($string =~/"/) {
1280         $string =~ s/"(.*?)"/__X__/;
1281         $commacontent = $1;
1282         warn "commacontent : $commacontent" if $DEBUG;
1283     }
1284     # split the query string in 3 parts : X AND Y means : $left="X", $operand="AND" and $right="Y"
1285     # then, call again NZanalyse with $left and $right
1286     # (recursive until we find a leaf (=> something without and/or/not)
1287     # delete repeated operator... Would then go in infinite loop
1288     while ($string =~s/( and| or| not| AND| OR| NOT)\1/$1/g){
1289     }
1290     #process parenthesis before.
1291     if ($string =~ /^\s*\((.*)\)(( and | or | not | AND | OR | NOT )(.*))?/){
1292       my $left = $1;
1293       my $right = $4;
1294       my $operator = lc($3); # FIXME: and/or/not are operators, not operands
1295       warn "dealing w/parenthesis before recursive sub call. left :$left operator:$operator right:$right" if $DEBUG;
1296       my $leftresult = NZanalyse($left,$server);
1297       if ($operator) {
1298         my $rightresult = NZanalyse($right,$server);
1299         # OK, we have the results for right and left part of the query
1300         # depending of operand, intersect, union or exclude both lists
1301         # to get a result list
1302         if ($operator eq ' and ') {
1303             my @leftresult = split /;/, $leftresult;
1304             warn " @leftresult / $rightresult \n" if $DEBUG;
1305 #             my @rightresult = split /;/,$leftresult;
1306             my $finalresult;
1307             # parse the left results, and if the biblionumber exist in the right result, save it in finalresult
1308             # the result is stored twice, to have the same weight for AND than OR.
1309             # example : TWO : 61,61,64,121 (two is twice in the biblio #61) / TOWER : 61,64,130
1310             # result : 61,61,61,61,64,64 for two AND tower : 61 has more weight than 64
1311             foreach (@leftresult) {
1312                 my $value=$_;
1313                 my $countvalue;
1314                 ($value,$countvalue)=($1,$2) if $value=~m/(.*)-(\d+)$/;
1315                 if ($rightresult =~ /$value-(\d+);/) {
1316                     $countvalue=($1>$countvalue?$countvalue:$1);
1317                     $finalresult .= "$value-$countvalue;$value-$countvalue;";
1318                 }
1319             }
1320             warn " $finalresult \n" if $DEBUG;
1321             return $finalresult;
1322         } elsif ($operator eq ' or ') {
1323             # just merge the 2 strings
1324             return $leftresult.$rightresult;
1325         } elsif ($operator eq ' not ') {
1326             my @leftresult = split /;/, $leftresult;
1327 #             my @rightresult = split /;/,$leftresult;
1328             my $finalresult;
1329             foreach (@leftresult) {
1330                 my $value=$_;
1331                 $value=$1 if $value=~m/(.*)-\d+$/;
1332                 unless ($rightresult =~ "$value-") {
1333                 }
1334             }
1335             return $finalresult;
1336         } else {
1337             # this error is impossible, because of the regexp that isolate the operand, but just in case...
1338             return $leftresult;
1339             exit;
1340         }
1341       }
1342     }
1343     warn "string :".$string if $DEBUG;
1344     $string =~ /(.*?)( and | or | not | AND | OR | NOT )(.*)/;
1345     my $left = $1;
1346     my $right = $3;
1347     my $operator = lc($2); # FIXME: and/or/not are operators, not operands
1348     warn "dealing w/parenthesis. left :$left operator:$operator right:$right" if $DEBUG;
1349     # it's not a leaf, we have a and/or/not
1350     if ($operator) {
1351         # reintroduce comma content if needed
1352         $right =~ s/__X__/"$commacontent"/ if $commacontent;
1353         $left =~ s/__X__/"$commacontent"/ if $commacontent;
1354         warn "node : $left / $operator / $right\n" if $DEBUG;
1355         my $leftresult = NZanalyse($left,$server);
1356         my $rightresult = NZanalyse($right,$server);
1357         # OK, we have the results for right and left part of the query
1358         # depending of operand, intersect, union or exclude both lists
1359         # to get a result list
1360         if ($operator eq ' and ') {
1361             my @leftresult = split /;/, $leftresult;
1362 #             my @rightresult = split /;/,$leftresult;
1363             my $finalresult;
1364             # parse the left results, and if the biblionumber exist in the right result, save it in finalresult
1365             # the result is stored twice, to have the same weight for AND than OR.
1366             # example : TWO : 61,61,64,121 (two is twice in the biblio #61) / TOWER : 61,64,130
1367             # result : 61,61,61,61,64,64 for two AND tower : 61 has more weight than 64
1368             foreach (@leftresult) {
1369                 if ($rightresult =~ "$_;") {
1370                     $finalresult .= "$_;$_;";
1371                 }
1372             }
1373             return $finalresult;
1374         } elsif ($operator eq ' or ') {
1375             # just merge the 2 strings
1376             return $leftresult.$rightresult;
1377         } elsif ($operator eq ' not ') {
1378             my @leftresult = split /;/, $leftresult;
1379 #             my @rightresult = split /;/,$leftresult;
1380             my $finalresult;
1381             foreach (@leftresult) {
1382                 unless ($rightresult =~ "$_;") {
1383                     $finalresult .= "$_;";
1384                 }
1385             }
1386             return $finalresult;
1387         } else {
1388             # this error is impossible, because of the regexp that isolate the operand, but just in case...
1389             die "error : operand unknown : $operator for $string";
1390         }
1391     # it's a leaf, do the real SQL query and return the result
1392     } else {
1393         $string =~  s/__X__/"$commacontent"/ if $commacontent;
1394         $string =~ s/-|\.|\?|,|;|!|'|\(|\)|\[|\]|{|}|"|&|\+|\*|\// /g;
1395         warn "leaf:$string" if $DEBUG;
1396         # parse the string in in operator/operand/value again
1397         $string =~ /(.*)(>=|<=)(.*)/;
1398         my $left = $1;
1399         my $operator = $2;
1400         my $right = $3;
1401         warn "handling leaf... left:$left operator:$operator right:$right" if $DEBUG;
1402         unless ($operator) {
1403             $string =~ /(.*)(>|<|=)(.*)/;
1404             $left = $1;
1405             $operator = $2;
1406             $right = $3;
1407         warn "handling unless (operator)... left:$left operator:$operator right:$right" if $DEBUG;
1408         }
1409         my $results;
1410     # strip adv, zebra keywords, currently not handled in nozebra: wrdl, ext, phr...
1411         $left =~ s/[ ,].*$//;
1412         # automatic replace for short operators
1413         $left='title' if $left =~ '^ti$';
1414         $left='author' if $left =~ '^au$';
1415         $left='publisher' if $left =~ '^pb$';
1416         $left='subject' if $left =~ '^su$';
1417         $left='koha-Auth-Number' if $left =~ '^an$';
1418         $left='keyword' if $left =~ '^kw$';
1419         if ($operator && $left  ne 'keyword' ) {
1420             #do a specific search
1421             my $dbh = C4::Context->dbh;
1422             $operator='LIKE' if $operator eq '=' and $right=~ /%/;
1423             my $sth = $dbh->prepare("SELECT biblionumbers,value FROM nozebra WHERE server=? AND indexname=? AND value $operator ?");
1424             warn "$left / $operator / $right\n";
1425             # split each word, query the DB and build the biblionumbers result
1426             #sanitizing leftpart
1427             $left=~s/^\s+|\s+$//;
1428             foreach (split / /,$right) {
1429                 my $biblionumbers;
1430                 $_=~s/^\s+|\s+$//;
1431                 next unless $_;
1432                 warn "EXECUTE : $server, $left, $_";
1433                 $sth->execute($server, $left, $_) or warn "execute failed: $!";
1434                 while (my ($line,$value) = $sth->fetchrow) {
1435                     # if we are dealing with a numeric value, use only numeric results (in case of >=, <=, > or <)
1436                     # otherwise, fill the result
1437                     $biblionumbers .= $line unless ($right =~ /^\d+$/ && $value =~ /\D/);
1438                     warn "result : $value ". ($right =~ /\d/) . "==".(!$value =~ /\d/) ;#= $line";
1439                 }
1440                 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
1441                 if ($results) {
1442                     my @leftresult = split /;/, $biblionumbers;
1443                     my $temp;
1444                     foreach my $entry (@leftresult) { # $_ contains biblionumber,title-weight
1445                         # remove weight at the end
1446                         my $cleaned = $entry;
1447                         $cleaned =~ s/-\d*$//;
1448                         # if the entry already in the hash, take it & increase weight
1449                         warn "===== $cleaned =====" if $DEBUG;
1450                         if ($results =~ "$cleaned") {
1451                             $temp .= "$entry;$entry;";
1452                             warn "INCLUDING $entry" if $DEBUG;
1453                         }
1454                     }
1455                     $results = $temp;
1456                 } else {
1457                     $results = $biblionumbers;
1458                 }
1459             }
1460         } else {
1461             #do a complete search (all indexes), if index='kw' do complete search too.
1462             my $dbh = C4::Context->dbh;
1463             my $sth = $dbh->prepare("SELECT biblionumbers FROM nozebra WHERE server=? AND value LIKE ?");
1464             # split each word, query the DB and build the biblionumbers result
1465             foreach (split / /,$string) {
1466                 next if C4::Context->stopwords->{uc($_)}; # skip if stopword
1467                 warn "search on all indexes on $_" if $DEBUG;
1468                 my $biblionumbers;
1469                 next unless $_;
1470                 $sth->execute($server, $_);
1471                 while (my $line = $sth->fetchrow) {
1472                     $biblionumbers .= $line;
1473                 }
1474                 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
1475                 if ($results) {
1476                  warn "RES for $_ = $biblionumbers" if $DEBUG;
1477                     my @leftresult = split /;/, $biblionumbers;
1478                     my $temp;
1479                     foreach my $entry (@leftresult) { # $_ contains biblionumber,title-weight
1480                         # remove weight at the end
1481                         my $cleaned = $entry;
1482                         $cleaned =~ s/-\d*$//;
1483                         # if the entry already in the hash, take it & increase weight
1484 #                          warn "===== $cleaned =====" if $DEBUG;
1485                         if ($results =~ "$cleaned") {
1486                             $temp .= "$entry;$entry;";
1487 #                              warn "INCLUDING $entry" if $DEBUG;
1488                         }
1489                     }
1490                     $results = $temp;
1491                 } else {
1492                  warn "NEW RES for $_ = $biblionumbers" if $DEBUG;
1493                     $results = $biblionumbers;
1494                 }
1495             }
1496         }
1497          warn "return : $results for LEAF : $string" if $DEBUG;
1498         return $results;
1499     }
1500     warn "---------" if $DEBUG;
1501     warn "Leave NZanalyse" if $DEBUG;
1502     warn "---------" if $DEBUG;
1503 }
1504
1505 =head2 NZorder
1506
1507   $finalresult = NZorder($biblionumbers, $ordering,$results_per_page,$offset);
1508
1509   TODO :: Description
1510
1511 =cut
1512
1513
1514 sub NZorder {
1515     my ($biblionumbers, $ordering,$results_per_page,$offset) = @_;
1516     warn "biblionumbers = $biblionumbers and ordering = $ordering\n" if $DEBUG;
1517     # order title asc by default
1518 #     $ordering = '1=36 <i' unless $ordering;
1519     $results_per_page=20 unless $results_per_page;
1520     $offset = 0 unless $offset;
1521     my $dbh = C4::Context->dbh;
1522     #
1523     # order by POPULARITY
1524     #
1525     if ($ordering =~ /popularity/) {
1526         my %result;
1527         my %popularity;
1528         # popularity is not in MARC record, it's builded from a specific query
1529         my $sth = $dbh->prepare("select sum(issues) from items where biblionumber=?");
1530         foreach (split /;/,$biblionumbers) {
1531             my ($biblionumber,$title) = split /,/,$_;
1532             $result{$biblionumber}=GetMarcBiblio($biblionumber);
1533             $sth->execute($biblionumber);
1534             my $popularity= $sth->fetchrow ||0;
1535             # hint : the key is popularity.title because we can have
1536             # many results with the same popularity. In this cas, sub-ordering is done by title
1537             # we also have biblionumber to avoid bug for 2 biblios with the same title & popularity
1538             # (un-frequent, I agree, but we won't forget anything that way ;-)
1539             $popularity{sprintf("%10d",$popularity).$title.$biblionumber} = $biblionumber;
1540         }
1541         # sort the hash and return the same structure as GetRecords (Zebra querying)
1542         my $result_hash;
1543         my $numbers=0;
1544         if ($ordering eq 'popularity_dsc') { # sort popularity DESC
1545             foreach my $key (sort {$b cmp $a} (keys %popularity)) {
1546                 $result_hash->{'RECORDS'}[$numbers++] = $result{$popularity{$key}}->as_usmarc();
1547             }
1548         } else { # sort popularity ASC
1549             foreach my $key (sort (keys %popularity)) {
1550                 $result_hash->{'RECORDS'}[$numbers++] = $result{$popularity{$key}}->as_usmarc();
1551             }
1552         }
1553         my $finalresult=();
1554         $result_hash->{'hits'} = $numbers;
1555         $finalresult->{'biblioserver'} = $result_hash;
1556         return $finalresult;
1557     #
1558     # ORDER BY author
1559     #
1560     } elsif ($ordering =~/author/){
1561         my %result;
1562         foreach (split /;/,$biblionumbers) {
1563             my ($biblionumber,$title) = split /,/,$_;
1564             my $record=GetMarcBiblio($biblionumber);
1565             my $author;
1566             if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1567                 $author=$record->subfield('200','f');
1568                 $author=$record->subfield('700','a') unless $author;
1569             } else {
1570                 $author=$record->subfield('100','a');
1571             }
1572             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1573             # and we don't want to get only 1 result for each of them !!!
1574             $result{$author.$biblionumber}=$record;
1575         }
1576         # sort the hash and return the same structure as GetRecords (Zebra querying)
1577         my $result_hash;
1578         my $numbers=0;
1579         if ($ordering eq 'author_za') { # sort by author desc
1580             foreach my $key (sort { $b cmp $a } (keys %result)) {
1581                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1582             }
1583         } else { # sort by author ASC
1584             foreach my $key (sort (keys %result)) {
1585                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1586             }
1587         }
1588         my $finalresult=();
1589         $result_hash->{'hits'} = $numbers;
1590         $finalresult->{'biblioserver'} = $result_hash;
1591         return $finalresult;
1592     #
1593     # ORDER BY callnumber
1594     #
1595     } elsif ($ordering =~/callnumber/){
1596         my %result;
1597         foreach (split /;/,$biblionumbers) {
1598             my ($biblionumber,$title) = split /,/,$_;
1599             my $record=GetMarcBiblio($biblionumber);
1600             my $callnumber;
1601             my ($callnumber_tag,$callnumber_subfield)=GetMarcFromKohaField($dbh,'items.itemcallnumber');
1602             ($callnumber_tag,$callnumber_subfield)= GetMarcFromKohaField('biblioitems.callnumber') unless $callnumber_tag;
1603             if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1604                 $callnumber=$record->subfield('200','f');
1605             } else {
1606                 $callnumber=$record->subfield('100','a');
1607             }
1608             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1609             # and we don't want to get only 1 result for each of them !!!
1610             $result{$callnumber.$biblionumber}=$record;
1611         }
1612         # sort the hash and return the same structure as GetRecords (Zebra querying)
1613         my $result_hash;
1614         my $numbers=0;
1615         if ($ordering eq 'call_number_dsc') { # sort by title desc
1616             foreach my $key (sort { $b cmp $a } (keys %result)) {
1617                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1618             }
1619         } else { # sort by title ASC
1620             foreach my $key (sort { $a cmp $b } (keys %result)) {
1621                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1622             }
1623         }
1624         my $finalresult=();
1625         $result_hash->{'hits'} = $numbers;
1626         $finalresult->{'biblioserver'} = $result_hash;
1627         return $finalresult;
1628     } elsif ($ordering =~ /pubdate/){ #pub year
1629         my %result;
1630         foreach (split /;/,$biblionumbers) {
1631             my ($biblionumber,$title) = split /,/,$_;
1632             my $record=GetMarcBiblio($biblionumber);
1633             my ($publicationyear_tag,$publicationyear_subfield)=GetMarcFromKohaField('biblioitems.publicationyear','');
1634             my $publicationyear=$record->subfield($publicationyear_tag,$publicationyear_subfield);
1635             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1636             # and we don't want to get only 1 result for each of them !!!
1637             $result{$publicationyear.$biblionumber}=$record;
1638         }
1639         # sort the hash and return the same structure as GetRecords (Zebra querying)
1640         my $result_hash;
1641         my $numbers=0;
1642         if ($ordering eq 'pubdate_dsc') { # sort by pubyear desc
1643             foreach my $key (sort { $b cmp $a } (keys %result)) {
1644                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1645             }
1646         } else { # sort by pub year ASC
1647             foreach my $key (sort (keys %result)) {
1648                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1649             }
1650         }
1651         my $finalresult=();
1652         $result_hash->{'hits'} = $numbers;
1653         $finalresult->{'biblioserver'} = $result_hash;
1654         return $finalresult;
1655     #
1656     # ORDER BY title
1657     #
1658     } elsif ($ordering =~ /title/) {
1659         # the title is in the biblionumbers string, so we just need to build a hash, sort it and return
1660         my %result;
1661         foreach (split /;/,$biblionumbers) {
1662             my ($biblionumber,$title) = split /,/,$_;
1663             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1664             # and we don't want to get only 1 result for each of them !!!
1665             # hint & speed improvement : we can order without reading the record
1666             # so order, and read records only for the requested page !
1667             $result{$title.$biblionumber}=$biblionumber;
1668         }
1669         # sort the hash and return the same structure as GetRecords (Zebra querying)
1670         my $result_hash;
1671         my $numbers=0;
1672         if ($ordering eq 'title_az') { # sort by title desc
1673             foreach my $key (sort (keys %result)) {
1674                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key};
1675             }
1676         } else { # sort by title ASC
1677             foreach my $key (sort { $b cmp $a } (keys %result)) {
1678                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key};
1679             }
1680         }
1681         # limit the $results_per_page to result size if it's more
1682         $results_per_page = $numbers-1 if $numbers < $results_per_page;
1683         # for the requested page, replace biblionumber by the complete record
1684         # speed improvement : avoid reading too much things
1685         for (my $counter=$offset;$counter<=$offset+$results_per_page;$counter++) {
1686             $result_hash->{'RECORDS'}[$counter] = GetMarcBiblio($result_hash->{'RECORDS'}[$counter])->as_usmarc;
1687         }
1688         my $finalresult=();
1689         $result_hash->{'hits'} = $numbers;
1690         $finalresult->{'biblioserver'} = $result_hash;
1691         return $finalresult;
1692     } else {
1693     #
1694     # order by ranking
1695     #
1696         # we need 2 hashes to order by ranking : the 1st one to count the ranking, the 2nd to order by ranking
1697         my %result;
1698         my %count_ranking;
1699         foreach (split /;/,$biblionumbers) {
1700             my ($biblionumber,$title) = split /,/,$_;
1701             $title =~ /(.*)-(\d)/;
1702             # get weight
1703             my $ranking =$2;
1704             # note that we + the ranking because ranking is calculated on weight of EACH term requested.
1705             # if we ask for "two towers", and "two" has weight 2 in biblio N, and "towers" has weight 4 in biblio N
1706             # biblio N has ranking = 6
1707             $count_ranking{$biblionumber} += $ranking;
1708         }
1709         # build the result by "inverting" the count_ranking hash
1710         # 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
1711 #         warn "counting";
1712         foreach (keys %count_ranking) {
1713             $result{sprintf("%10d",$count_ranking{$_}).'-'.$_} = $_;
1714         }
1715         # sort the hash and return the same structure as GetRecords (Zebra querying)
1716         my $result_hash;
1717         my $numbers=0;
1718             foreach my $key (sort {$b cmp $a} (keys %result)) {
1719                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key};
1720             }
1721         # limit the $results_per_page to result size if it's more
1722         $results_per_page = $numbers-1 if $numbers < $results_per_page;
1723         # for the requested page, replace biblionumber by the complete record
1724         # speed improvement : avoid reading too much things
1725         for (my $counter=$offset;$counter<=$offset+$results_per_page;$counter++) {
1726             $result_hash->{'RECORDS'}[$counter] = GetMarcBiblio($result_hash->{'RECORDS'}[$counter])->as_usmarc if $result_hash->{'RECORDS'}[$counter];
1727         }
1728         my $finalresult=();
1729         $result_hash->{'hits'} = $numbers;
1730         $finalresult->{'biblioserver'} = $result_hash;
1731         return $finalresult;
1732     }
1733 }
1734 =head2 ModBiblios
1735
1736 ($countchanged,$listunchanged) = ModBiblios($listbiblios, $tagsubfield,$initvalue,$targetvalue,$test);
1737
1738 this function changes all the values $initvalue in subfield $tag$subfield in any record in $listbiblios
1739 test parameter if set donot perform change to records in database.
1740
1741 =over 2
1742
1743 =item C<input arg:>
1744
1745     * $listbiblios is an array ref to marcrecords to be changed
1746     * $tagsubfield is the reference of the subfield to change.
1747     * $initvalue is the value to search the record for
1748     * $targetvalue is the value to set the subfield to
1749     * $test is to be set only not to perform changes in database.
1750
1751 =item C<Output arg:>
1752     * $countchanged counts all the changes performed.
1753     * $listunchanged contains the list of all the biblionumbers of records unchanged.
1754
1755 =item C<usage in the script:>
1756
1757 =back
1758
1759 my ($countchanged, $listunchanged) = EditBiblios($results->{RECORD}, $tagsubfield,$initvalue,$targetvalue);;
1760 #If one wants to display unchanged records, you should get biblios foreach @$listunchanged
1761 $template->param(countchanged => $countchanged, loopunchanged=>$listunchanged);
1762
1763 =cut
1764
1765 sub ModBiblios{
1766   my ($listbiblios,$tagsubfield,$initvalue,$targetvalue,$test)=@_;
1767   my $countmatched;
1768   my @unmatched;
1769   my ($tag,$subfield)=($1,$2) if ($tagsubfield=~/^(\d{1,3})([a-z0-9A-Z@])?$/);
1770   if ((length($tag)<3)&& $subfield=~/0-9/){
1771     $tag=$tag.$subfield;
1772     undef $subfield;
1773   }
1774   my ($bntag,$bnsubf) = GetMarcFromKohaField('biblio.biblionumber');
1775   my ($itemtag,$itemsubf) = GetMarcFromKohaField('items.itemnumber');
1776   foreach my $usmarc (@$listbiblios){
1777     my $record;
1778     $record=eval{MARC::Record->new_from_usmarc($usmarc)};
1779     my $biblionumber;
1780     if ($@){
1781       # usmarc is not a valid usmarc May be a biblionumber
1782       if ($tag eq $itemtag){
1783         my $bib=GetBiblioFromItemNumber($usmarc);
1784         $record=GetMarcItem($bib->{'biblionumber'},$usmarc) ;
1785         $biblionumber=$bib->{'biblionumber'};
1786       } else {
1787         $record=GetMarcBiblio($usmarc);
1788         $biblionumber=$usmarc;
1789       }
1790     }  else {
1791       if ($bntag >= 010){
1792         $biblionumber = $record->subfield($bntag,$bnsubf);
1793       }else {
1794         $biblionumber=$record->field($bntag)->data;
1795       }
1796     }
1797     #GetBiblionumber is to be written.
1798     #Could be replaced by TransformMarcToKoha (But Would be longer)
1799     if ($record->field($tag)){
1800       my $modify=0;
1801       foreach my $field ($record->field($tag)){
1802         if ($subfield){
1803           if ($field->delete_subfield('code' =>$subfield,'match'=>qr($initvalue))){
1804             $countmatched++;
1805             $modify=1;
1806             $field->update($subfield,$targetvalue) if ($targetvalue);
1807           }
1808         } else {
1809           if ($tag >= 010){
1810             if ($field->delete_field($field)){
1811               $countmatched++;
1812               $modify=1;
1813             }
1814           } else {
1815             $field->data=$targetvalue if ($field->data=~qr($initvalue));
1816           }
1817         }
1818       }
1819 #       warn $record->as_formatted;
1820       if ($modify){
1821         ModBiblio($record,$biblionumber,GetFrameworkCode($biblionumber)) unless ($test);
1822       } else {
1823         push @unmatched, $biblionumber;
1824       }
1825     } else {
1826       push @unmatched, $biblionumber;
1827     }
1828   }
1829   return ($countmatched,\@unmatched);
1830 }
1831
1832 END { }    # module clean-up code here (global destructor)
1833
1834 1;
1835 __END__
1836
1837 =head1 AUTHOR
1838
1839 Koha Developement team <info@koha.org>
1840
1841 =cut