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     my @operators = @$operators if $operators;
 692     my @indexes   = @$indexes   if $indexes;
 693     my @operands  = @$operands  if $operands;
 694     my @limits    = @$limits    if $limits;
 695     my @sort_by   = @$sort_by   if $sort_by;
 696
 697     my $stemming      = C4::Context->preference("QueryStemming")                || 0;
 698         my $auto_truncation = C4::Context->preference("QueryAutoTruncate")              || 0;
 699     my $weight_fields = C4::Context->preference("QueryWeightFields")            || 0;
 700     my $fuzzy_enabled = C4::Context->preference("QueryFuzzy")                           || 0;
 701     # no stemming/weight/fuzzy in NoZebra
 702     if (C4::Context->preference("NoZebra")) {
 703         $stemming =0;
 704         $weight_fields=0;
 705         $fuzzy_enabled=0;
 706     }
 707         my $remove_stopwords = C4::Context->preference("QueryRemoveStopwords")  || 0;
 708
 709     my $query = $operands[0];
 710         my $simple_query = $operands[0];
 711         my $query_cgi;
 712         my $query_desc;
 713         my $query_type;
 714
 715         my $limit;
 716         my $limit_cgi;
 717         my $limit_desc;
 718
 719         my $stopwords_removed;
 720
 721         # for handling ccl, cql, pqf queries in diagnostic mode, skip the rest of the steps
 722         # DIAGNOSTIC ONLY!!
 723     if ( $query =~ /^ccl=/ ) {
 724         return ( undef, $', $', $', $', '', '', '', '', 'ccl' );
 725     }
 726     if ( $query =~ /^cql=/ ) {
 727         return ( undef, $', $', $', $', '', '', '', '', 'cql' );
 728     }
 729     if ( $query =~ /^pqf=/ ) {
 730         return ( undef, $', $', $', $', '', '', '', '', 'pqf' );
 731     }
 732
 733         # pass nested queries directly
 734     if ( $query =~ /(\(|\))/ ) {
 735         return ( undef, $query, $simple_query, $query_cgi, $query, $limit, $limit_cgi, $limit_desc, $stopwords_removed, 'ccl' );
 736     }
 737
 738 # form-based queries are limited to non-nested at a specific depth, so we can easily
 739 # modify the incoming query operands and indexes to do stemming and field weighting
 740 # Once we do so, we'll end up with a value in $query, just like if we had an
 741 # incoming $query from the user
 742     else {
 743         $query = ""; # clear it out so we can populate properly with field-weighted stemmed query
 744         my $previous_operand;    # a flag used to keep track if there was a previous query
 745                                 # if there was, we can apply the current operator
 746         # for every operand
 747         for ( my $i = 0 ; $i <= @operands ; $i++ ) {
 748
 749             # COMBINE OPERANDS, INDEXES AND OPERATORS
 750             if ( $operands[$i] ) {
 751
 752                                 # a flag to determine whether or not to add the index to the query
 753                                 my $indexes_set;
 754
 755                                 # if the user is sophisticated enough to specify an index, turn off field weighting, stemming, and stopword handling
 756                                 if ($operands[$i] =~ /(:|=)/ || $scan) {
 757                                         $weight_fields = 0;
 758                                         $stemming = 0;
 759                                         $remove_stopwords = 0;
 760                                 }
 761                 my $operand = $operands[$i];
 762                 my $index   = $indexes[$i];
 763
 764                                 # add some attributes for certain index types
 765                                 # Date of Publication
 766                                 if ($index eq 'yr') {
 767                                         $index .=",st-numeric";
 768                                         $indexes_set++;
 769                                         ($stemming,$auto_truncation,$weight_fields, $fuzzy_enabled, $remove_stopwords) = (0,0,0,0,0);
 770                                 }
 771                                 # Date of Acquisition
 772                                 elsif ($index eq 'acqdate') {
 773                                         $index.=",st-date-normalized";
 774                                         $indexes_set++;
 775                                         ($stemming,$auto_truncation,$weight_fields, $fuzzy_enabled, $remove_stopwords) = (0,0,0,0,0);
 776
 777                                 }
 778
 779                                 # set default structure attribute (word list)
 780                                 my $struct_attr;
 781                                 unless (!$index || $index =~ /(st-|phr|ext|wrdl)/) {
 782                                         $struct_attr = ",wrdl";
 783                                 }
 784                                 # some helpful index modifs
 785                 my $index_plus = $index.$struct_attr.":" if $index;
 786                 my $index_plus_comma=$index.$struct_attr."," if $index;
 787
 788                 # Remove Stopwords
 789                                 if ($remove_stopwords) {
 790                 ($operand, $stopwords_removed) = _remove_stopwords($operand,$index);
 791                         warn "OPERAND w/out STOPWORDS: >$operand<" if $DEBUG;
 792                                         warn "REMOVED STOPWORDS: @$stopwords_removed" if ($stopwords_removed && $DEBUG);
 793                                 }
 794
 795                 # Detect Truncation
 796                 my ($nontruncated,$righttruncated,$lefttruncated,$rightlefttruncated,$regexpr);
 797                 my $truncated_operand;
 798                 ($nontruncated,$righttruncated,$lefttruncated,$rightlefttruncated,$regexpr) = _detect_truncation($operand,$index);
 799                 warn "TRUNCATION: NON:>@$nontruncated< RIGHT:>@$righttruncated< LEFT:>@$lefttruncated< RIGHTLEFT:>@$rightlefttruncated< REGEX:>@$regexpr<" if $DEBUG;
 800
 801                 # Apply Truncation
 802                 if (scalar(@$righttruncated)+scalar(@$lefttruncated)+scalar(@$rightlefttruncated)>0){
 803                                         # don't field weight or add the index to the query, we do it here
 804                     $indexes_set = 1;
 805                     undef $weight_fields;
 806                     my $previous_truncation_operand;
 807                     if (scalar(@$nontruncated)>0) {
 808                         $truncated_operand.= "$index_plus @$nontruncated ";
 809                         $previous_truncation_operand = 1;
 810                     }
 811                     if (scalar(@$righttruncated)>0){
 812                         $truncated_operand .= "and " if $previous_truncation_operand;
 813                         $truncated_operand .= "$index_plus_comma"."rtrn:@$righttruncated ";
 814                         $previous_truncation_operand = 1;
 815                     }
 816                     if (scalar(@$lefttruncated)>0){
 817                         $truncated_operand .= "and " if $previous_truncation_operand;
 818                         $truncated_operand .= "$index_plus_comma"."ltrn:@$lefttruncated ";
 819                         $previous_truncation_operand = 1;
 820                     }
 821                     if (scalar(@$rightlefttruncated)>0){
 822                         $truncated_operand .= "and " if $previous_truncation_operand;
 823                         $truncated_operand .= "$index_plus_comma"."rltrn:@$rightlefttruncated ";
 824                         $previous_truncation_operand = 1;
 825                     }
 826                 }
 827                 $operand = $truncated_operand if $truncated_operand;
 828                 warn "TRUNCATED OPERAND: >$truncated_operand<" if $DEBUG;
 829
 830                 # Handle Stemming
 831                 my $stemmed_operand;
 832                 $stemmed_operand = _build_stemmed_operand($operand) if $stemming;
 833                 warn "STEMMED OPERAND: >$stemmed_operand<" if $DEBUG;
 834
 835                 # Handle Field Weighting
 836                 my $weighted_operand;
 837                 $weighted_operand = _build_weighted_query($operand,$stemmed_operand,$index) if $weight_fields;
 838                 warn "FIELD WEIGHTED OPERAND: >$weighted_operand<" if $DEBUG;
 839                 $operand = $weighted_operand if $weight_fields;
 840                 $indexes_set = 1 if $weight_fields;
 841
 842                 # If there's a previous operand, we need to add an operator
 843                 if ($previous_operand) {
 844
 845                     # user-specified operator
 846                     if ( $operators[$i-1] ) {
 847                         $query .= " $operators[$i-1] ";
 848                         $query .= " $index_plus " unless $indexes_set;
 849                         $query .= " $operand";
 850                                                 $query_cgi .="&op=$operators[$i-1]";
 851                                                 $query_cgi .="&idx=$index" if $index;
 852                                                 $query_cgi .="&q=$operands[$i]" if $operands[$i];
 853                                                 $query_desc .=" $operators[$i-1] $index_plus $operands[$i]";
 854                     }
 855
 856                     # the default operator is and
 857                     else {
 858                         $query .= " and ";
 859                         $query .= "$index_plus " unless $indexes_set;
 860                         $query .= "$operand";
 861                                                 $query_cgi .="&op=and&idx=$index" if $index;
 862                                                 $query_cgi .="&q=$operands[$i]" if $operands[$i];
 863                         $query_desc .= " and $index_plus $operands[$i]";
 864                     }
 865                 }
 866
 867                                 # there isn't a pervious operand, don't need an operator
 868                 else {
 869                                         # field-weighted queries already have indexes set
 870                                         $query .=" $index_plus " unless $indexes_set;
 871                                         $query .= $operand;
 872                                         $query_desc .= " $index_plus $operands[$i]";
 873                                         $query_cgi.="&idx=$index" if $index;
 874                                         $query_cgi.="&q=$operands[$i]" if $operands[$i];
 875
 876                     $previous_operand = 1;
 877                 }
 878             }    #/if $operands
 879         }    # /for
 880     }
 881     warn "QUERY BEFORE LIMITS: >$query<" if $DEBUG;
 882
 883     # add limits
 884         my $group_OR_limits;
 885         my $availability_limit;
 886     foreach my $this_limit (@limits) {
 887         if ( $this_limit =~ /available/ ) {
 888                         # available is defined as (items.notloan is NULL) and (items.itemlost > 0 or NULL) (last clause handles NULL values for lost in zebra)
 889                         $availability_limit .="( ( allrecords,AlwaysMatches='' not onloan,AlwaysMatches='') and ((lost,st-numeric ge 0) or ( allrecords,AlwaysMatches='' not lost,AlwaysMatches='')) )";
 890                         $limit_cgi .= "&limit=available";
 891                         $limit_desc .="";
 892         }
 893
 894                 # these are treated as OR
 895         elsif ( $this_limit =~ /mc/ ) {
 896             $group_OR_limits .= " or " if $group_OR_limits;
 897                         $limit_desc .=" or " if $group_OR_limits;
 898                         $group_OR_limits .= "$this_limit";
 899                         $limit_cgi .="&limit=$this_limit";
 900                         $limit_desc .= " $this_limit";
 901         }
 902                 # regular old limits
 903                 else {
 904                         $limit .= " and " if $limit || $query;
 905                         $limit .= "$this_limit";
 906                         $limit_cgi .="&limit=$this_limit";
 907                         $limit_desc .=" $this_limit";
 908                 }
 909     }
 910         if ($group_OR_limits) {
 911                 $limit.=" and " if ($query || $limit );
 912                 $limit.="($group_OR_limits)";
 913         }
 914         if ($availability_limit) {
 915                 $limit.=" not " if ($query || $limit );
 916                 $limit.="$availability_limit";
 917         }
 918         # normalize the strings
 919         $query =~ s/:/=/g;
 920         $limit =~ s/:/=/g;
 921         for ($query, $query_desc, $limit, $limit_desc) {
 922                 $_ =~ s/  / /g;    # remove extra spaces
 923         $_ =~ s/^ //g;     # remove any beginning spaces
 924                 $_ =~ s/ $//g;     # remove any ending spaces
 925         $_ =~ s/==/=/g;    # remove double == from query
 926
 927         }
 928         $query_cgi =~ s/^&//;
 929
 930         # append the limit to the query
 931         $query .= " ".$limit;
 932
 933     warn "QUERY:".$query if $DEBUG;
 934         warn "QUERY CGI:".$query_cgi if $DEBUG;
 935     warn "QUERY DESC:".$query_desc if $DEBUG;
 936     warn "LIMIT:".$limit if $DEBUG;
 937     warn "LIMIT CGI:".$limit_cgi if $DEBUG;
 938     warn "LIMIT DESC:".$limit_desc if $DEBUG;
 939
 940         return ( undef, $query,$simple_query,$query_cgi,$query_desc,$limit,$limit_cgi,$limit_desc,$stopwords_removed,$query_type );
 941 }
 942
 943 # IMO this subroutine is pretty messy still -- it's responsible for
 944 # building the HTML output for the template
 945 sub searchResults {
 946     my ( $searchdesc, $hits, $results_per_page, $offset, @marcresults ) = @_;
 947
 948     my $dbh = C4::Context->dbh;
 949     my $toggle;
 950     my $even = 1;
 951     my @newresults;
 952     my $span_terms_hashref;
 953     for my $span_term ( split( / /, $searchdesc ) ) {
 954         $span_term =~ s/(.*=|\)|\(|\+|\.)//g;
 955         $span_terms_hashref->{$span_term}++;
 956     }
 957
 958     #Build brancnames hash
 959     #find branchname
 960     #get branch information.....
 961     my %branches;
 962     my $bsth =
 963       $dbh->prepare("SELECT branchcode,branchname FROM branches")
 964       ;    # FIXME : use C4::Koha::GetBranches
 965     $bsth->execute();
 966     while ( my $bdata = $bsth->fetchrow_hashref ) {
 967         $branches{ $bdata->{'branchcode'} } = $bdata->{'branchname'};
 968     }
 969
 970     #Build itemtype hash
 971     #find itemtype & itemtype image
 972     my %itemtypes;
 973     $bsth =
 974       $dbh->prepare("SELECT itemtype,description,imageurl,summary,notforloan FROM itemtypes");
 975     $bsth->execute();
 976     while ( my $bdata = $bsth->fetchrow_hashref ) {
 977         $itemtypes{ $bdata->{'itemtype'} }->{description} =
 978           $bdata->{'description'};
 979         $itemtypes{ $bdata->{'itemtype'} }->{imageurl} = $bdata->{'imageurl'};
 980         $itemtypes{ $bdata->{'itemtype'} }->{summary} = $bdata->{'summary'};
 981         $itemtypes{ $bdata->{'itemtype'} }->{notforloan} = $bdata->{'notforloan'};
 982     }
 983
 984     #search item field code
 985     my $sth =
 986       $dbh->prepare(
 987 "select tagfield from marc_subfield_structure where kohafield like 'items.itemnumber'"
 988       );
 989     $sth->execute;
 990     my ($itemtag) = $sth->fetchrow;
 991
 992     ## find column names of items related to MARC
 993     my $sth2 = $dbh->prepare("SHOW COLUMNS from items");
 994     $sth2->execute;
 995     my %subfieldstosearch;
 996     while ( ( my $column ) = $sth2->fetchrow ) {
 997         my ( $tagfield, $tagsubfield ) =
 998           &GetMarcFromKohaField( "items." . $column, "" );
 999         $subfieldstosearch{$column} = $tagsubfield;
1000     }
1001     my $times;
1002
1003     if ( $hits && $offset + $results_per_page <= $hits ) {
1004         $times = $offset + $results_per_page;
1005     }
1006     else {
1007         $times = $hits;
1008     }
1009
1010     for ( my $i = $offset ; $i <= $times - 1 ; $i++ ) {
1011         my $marcrecord;
1012         $marcrecord = MARC::File::USMARC::decode( $marcresults[$i] );
1013         my $oldbiblio = TransformMarcToKoha( $dbh, $marcrecord, '' );
1014                 $oldbiblio->{result_number} = $i+1;
1015         # add image url if there is one
1016         if ( $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} =~ /^http:/ ) {
1017             $oldbiblio->{imageurl} =
1018               $itemtypes{ $oldbiblio->{itemtype} }->{imageurl};
1019             $oldbiblio->{description} =
1020               $itemtypes{ $oldbiblio->{itemtype} }->{description};
1021         }
1022         else {
1023             $oldbiblio->{imageurl} =
1024               getitemtypeimagesrc() . "/"
1025               . $itemtypes{ $oldbiblio->{itemtype} }->{imageurl}
1026               if ( $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} );
1027             $oldbiblio->{description} =
1028               $itemtypes{ $oldbiblio->{itemtype} }->{description};
1029         }
1030         #
1031         # build summary if there is one (the summary is defined in itemtypes table
1032         #
1033         if ($itemtypes{ $oldbiblio->{itemtype} }->{summary}) {
1034             my $summary = $itemtypes{ $oldbiblio->{itemtype} }->{summary};
1035             my @fields = $marcrecord->fields();
1036             foreach my $field (@fields) {
1037                 my $tag = $field->tag();
1038                 my $tagvalue = $field->as_string();
1039                 $summary =~ s/\[(.?.?.?.?)$tag\*(.*?)]/$1$tagvalue$2\[$1$tag$2]/g;
1040                 unless ($tag<10) {
1041                     my @subf = $field->subfields;
1042                     for my $i (0..$#subf) {
1043                         my $subfieldcode = $subf[$i][0];
1044                         my $subfieldvalue = $subf[$i][1];
1045                         my $tagsubf = $tag.$subfieldcode;
1046                         $summary =~ s/\[(.?.?.?.?)$tagsubf(.*?)]/$1$subfieldvalue$2\[$1$tagsubf$2]/g;
1047                     }
1048                 }
1049             }
1050             $summary =~ s/\[(.*?)]//g;
1051             $summary =~ s/\n/<br>/g;
1052             $oldbiblio->{summary} = $summary;
1053         }
1054         # add spans to search term in results for search term highlighting
1055         # save a native author, for the <a href=search.lq=<!--tmpl_var name="author"-->> link
1056                 my $searchhighlightblob;
1057                 for my $highlight_field ($marcrecord->fields) {
1058                         next if $highlight_field->tag() =~ /(^00)/; # skip fixed fields
1059                         my $match;
1060                         my $field = $highlight_field->as_string();
1061                         for my $term ( keys %$span_terms_hashref ) {
1062                                 if (($field =~ /$term/i) && (length($term) > 3)) {
1063                                         $field =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1064                                         $match++;
1065                                 }
1066                         }
1067                         $searchhighlightblob .= $field." ... " if $match;
1068                 }
1069                 $oldbiblio->{'searchhighlightblob'} = $searchhighlightblob;
1070
1071         $oldbiblio->{'author_nospan'} = $oldbiblio->{'author'};
1072         for my $term ( keys %$span_terms_hashref ) {
1073             my $old_term = $term;
1074             if ( length($term) > 3 ) {
1075                 $term =~ s/(.*=|\)|\(|\+|\.|\?|\[|\]|\\|\*)//g;
1076                 $oldbiblio->{'title'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1077                 $oldbiblio->{'subtitle'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1078                 $oldbiblio->{'author'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1079                 $oldbiblio->{'publishercode'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1080                 $oldbiblio->{'place'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1081                 $oldbiblio->{'pages'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1082                 $oldbiblio->{'notes'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1083                 $oldbiblio->{'size'}  =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1084             }
1085         }
1086
1087         if ( $i % 2 ) {
1088             $toggle = "#ffffcc";
1089         }
1090         else {
1091             $toggle = "white";
1092         }
1093         $oldbiblio->{'toggle'} = $toggle;
1094         my @fields = $marcrecord->field($itemtag);
1095         my @items_loop;
1096         my $items;
1097         my $ordered_count     = 0;
1098         my $onloan_count      = 0;
1099         my $wthdrawn_count    = 0;
1100         my $itemlost_count    = 0;
1101         my $norequests        = 1;
1102
1103         #
1104         # check the loan status of the item :
1105         # it is not stored in the MARC record, for pref (zebra reindexing)
1106         # reason. Thus, we have to get the status from a specific SQL query
1107         #
1108         my $sth_issue = $dbh->prepare("
1109             SELECT date_due,returndate
1110             FROM issues
1111             WHERE itemnumber=? AND returndate IS NULL");
1112         my $items_count=scalar(@fields);
1113         foreach my $field (@fields) {
1114             my $item;
1115             foreach my $code ( keys %subfieldstosearch ) {
1116                 $item->{$code} = $field->subfield( $subfieldstosearch{$code} );
1117             }
1118             $sth_issue->execute($item->{itemnumber});
1119             $item->{due_date} = format_date($sth_issue->fetchrow) if $sth_issue->fetchrow;
1120             $item->{onloan} = 1 if $item->{due_date};
1121             # at least one item can be reserved : suppose no
1122             $norequests = 1;
1123             if ( $item->{wthdrawn} ) {
1124                 $wthdrawn_count++;
1125                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{unavailable}=1;
1126                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{wthdrawn}=1;
1127             }
1128             elsif ( $item->{itemlost} ) {
1129                 $itemlost_count++;
1130                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{unavailable}=1;
1131                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{itemlost}=1;
1132             }
1133             unless ( $item->{notforloan}) {
1134                 # OK, this one can be issued, so at least one can be reserved
1135                 $norequests = 0;
1136             }
1137             if ( ( $item->{onloan} ) && ( $item->{onloan} != '0000-00-00' ) )
1138             {
1139                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{unavailable}=1;
1140                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{onloancount} = 1;
1141                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{due_date} = $item->{due_date};
1142                 $onloan_count++;
1143             }
1144             if ( $item->{'homebranch'} ) {
1145                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{count}++;
1146             }
1147
1148             # Last resort
1149             elsif ( $item->{'holdingbranch'} ) {
1150                 $items->{ $item->{'holdingbranch'} }->{count}++;
1151             }
1152             $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{itemcallnumber} =                $item->{itemcallnumber};
1153             $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{location} =                $item->{location};
1154             $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{branchcode} =               $item->{homebranch};
1155         }    # notforloan, item level and biblioitem level
1156
1157         # last check for norequest : if itemtype is notforloan, it can't be reserved either, whatever the items
1158         $norequests = 1 if $itemtypes{$oldbiblio->{itemtype}}->{notforloan};
1159                 my $itemscount;
1160         for my $key ( sort keys %$items ) {
1161                         $itemscount++;
1162             my $this_item = {
1163                 branchname     => $branches{$items->{$key}->{branchcode}},
1164                 branchcode     => $items->{$key}->{branchcode},
1165                 count          => $items->{$key}->{count},
1166                 itemcallnumber => $items->{$key}->{itemcallnumber},
1167                 location => $items->{$key}->{location},
1168                 onloancount      => $items->{$key}->{onloancount},
1169                 due_date         => $items->{$key}->{due_date},
1170                 wthdrawn      => $items->{$key}->{wthdrawn},
1171                 lost         => $items->{$key}->{itemlost},
1172             };
1173                         # only show the number specified by the user
1174                         my $maxitems = (C4::Context->preference('maxItemsinSearchResults')) ? C4::Context->preference('maxItemsinSearchResults')- 1 : 1;
1175             push @items_loop, $this_item unless $itemscount > $maxitems;;
1176         }
1177         $oldbiblio->{norequests}    = $norequests;
1178         $oldbiblio->{items_count}    = $items_count;
1179         $oldbiblio->{items_loop}    = \@items_loop;
1180         $oldbiblio->{onloancount}   = $onloan_count;
1181         $oldbiblio->{wthdrawncount} = $wthdrawn_count;
1182         $oldbiblio->{itemlostcount} = $itemlost_count;
1183         $oldbiblio->{orderedcount}  = $ordered_count;
1184         $oldbiblio->{isbn}          =~ s/-//g; # deleting - in isbn to enable amazon content
1185         push( @newresults, $oldbiblio );
1186     }
1187     return @newresults;
1188 }
1189
1190
1191
1192 #----------------------------------------------------------------------
1193 #
1194 # Non-Zebra GetRecords#
1195 #----------------------------------------------------------------------
1196
1197 =head2 NZgetRecords
1198
1199   NZgetRecords has the same API as zera getRecords, even if some parameters are not managed
1200
1201 =cut
1202 sub NZgetRecords {
1203     my ($query,$simple_query,$sort_by_ref,$servers_ref,$results_per_page,$offset,$expanded_facet,$branches,$query_type,$scan) = @_;
1204     my $result = NZanalyse($query);
1205     return (undef,NZorder($result,@$sort_by_ref[0],$results_per_page,$offset),undef);
1206 }
1207
1208 =head2 NZanalyse
1209
1210   NZanalyse : get a CQL string as parameter, and returns a list of biblionumber;title,biblionumber;title,...
1211   the list is built from an inverted index in the nozebra SQL table
1212   note that title is here only for convenience : the sorting will be very fast when requested on title
1213   if the sorting is requested on something else, we will have to reread all results, and that may be longer.
1214
1215 =cut
1216
1217 sub NZanalyse {
1218     my ($string,$server) = @_;
1219     # $server contains biblioserver or authorities, depending on what we search on.
1220     #warn "querying : $string on $server";
1221     $server='biblioserver' unless $server;
1222
1223     # if we have a ", replace the content to discard temporarily any and/or/not inside
1224     my $commacontent;
1225     if ($string =~/"/) {
1226         $string =~ s/"(.*?)"/__X__/;
1227         $commacontent = $1;
1228                 warn "commacontent : $commacontent" if $DEBUG;
1229     }
1230     # split the query string in 3 parts : X AND Y means : $left="X", $operand="AND" and $right="Y"
1231     # then, call again NZanalyse with $left and $right
1232     # (recursive until we find a leaf (=> something without and/or/not)
1233     # delete repeated operator... Would then go in infinite loop
1234     while ($string =~s/( and| or| not| AND| OR| NOT)\1/$1/g){
1235     }
1236     #process parenthesis before.
1237     if ($string =~ /^\s*\((.*)\)(( and | or | not | AND | OR | NOT )(.*))?/){
1238       my $left = $1;
1239 #       warn "left :".$left;
1240       my $right = $4;
1241       my $operator = lc($3); # FIXME: and/or/not are operators, not operands
1242       my $leftresult = NZanalyse($left,$server);
1243       if ($operator) {
1244         my $rightresult = NZanalyse($right,$server);
1245         # OK, we have the results for right and left part of the query
1246         # depending of operand, intersect, union or exclude both lists
1247         # to get a result list
1248         if ($operator eq ' and ') {
1249             my @leftresult = split /;/, $leftresult;
1250 #             my @rightresult = split /;/,$leftresult;
1251             my $finalresult;
1252             # parse the left results, and if the biblionumber exist in the right result, save it in finalresult
1253             # the result is stored twice, to have the same weight for AND than OR.
1254             # example : TWO : 61,61,64,121 (two is twice in the biblio #61) / TOWER : 61,64,130
1255             # result : 61,61,61,61,64,64 for two AND tower : 61 has more weight than 64
1256             foreach (@leftresult) {
1257                 if ($rightresult =~ "$_;") {
1258                     $finalresult .= "$_;$_;";
1259                 }
1260             }
1261             return $finalresult;
1262         } elsif ($operator eq ' or ') {
1263             # just merge the 2 strings
1264             return $leftresult.$rightresult;
1265         } elsif ($operator eq ' not ') {
1266             my @leftresult = split /;/, $leftresult;
1267 #             my @rightresult = split /;/,$leftresult;
1268             my $finalresult;
1269             foreach (@leftresult) {
1270                 unless ($rightresult =~ "$_;") {
1271                     $finalresult .= "$_;";
1272                 }
1273             }
1274             return $finalresult;
1275         } else {
1276             # this error is impossible, because of the regexp that isolate the operand, but just in case...
1277             return $leftresult;
1278             exit;
1279         }
1280       }
1281     }
1282     warn "string :".$string if $DEBUG;
1283     $string =~ /(.*?)( and | or | not | AND | OR | NOT )(.*)/;
1284     my $left = $1;
1285     my $right = $3;
1286     my $operand = lc($2); # FIXME: and/or/not are operators, not operands
1287     # it's not a leaf, we have a and/or/not
1288     if ($operand) {
1289         # reintroduce comma content if needed
1290         $right =~ s/__X__/"$commacontent"/ if $commacontent;
1291         $left =~ s/__X__/"$commacontent"/ if $commacontent;
1292         warn "node : $left / $operand / $right\n" if $DEBUG;
1293         my $leftresult = NZanalyse($left,$server);
1294         my $rightresult = NZanalyse($right,$server);
1295         # OK, we have the results for right and left part of the query
1296         # depending of operand, intersect, union or exclude both lists
1297         # to get a result list
1298         if ($operand eq ' and ') {
1299             my @leftresult = split /;/, $leftresult;
1300 #             my @rightresult = split /;/,$leftresult;
1301             my $finalresult;
1302             # parse the left results, and if the biblionumber exist in the right result, save it in finalresult
1303             # the result is stored twice, to have the same weight for AND than OR.
1304             # example : TWO : 61,61,64,121 (two is twice in the biblio #61) / TOWER : 61,64,130
1305             # result : 61,61,61,61,64,64 for two AND tower : 61 has more weight than 64
1306             foreach (@leftresult) {
1307                 if ($rightresult =~ "$_;") {
1308                     $finalresult .= "$_;$_;";
1309                 }
1310             }
1311             return $finalresult;
1312         } elsif ($operand eq ' or ') {
1313             # just merge the 2 strings
1314             return $leftresult.$rightresult;
1315         } elsif ($operand eq ' not ') {
1316             my @leftresult = split /;/, $leftresult;
1317 #             my @rightresult = split /;/,$leftresult;
1318             my $finalresult;
1319             foreach (@leftresult) {
1320                 unless ($rightresult =~ "$_;") {
1321                     $finalresult .= "$_;";
1322                 }
1323             }
1324             return $finalresult;
1325         } else {
1326             # this error is impossible, because of the regexp that isolate the operand, but just in case...
1327             die "error : operand unknown : $operand for $string";
1328         }
1329     # it's a leaf, do the real SQL query and return the result
1330     } else {
1331         $string =~  s/__X__/"$commacontent"/ if $commacontent;
1332         $string =~ s/-|\.|\?|,|;|!|'|\(|\)|\[|\]|{|}|"|&|\+|\*|\// /g;
1333         warn "leaf : $string\n" if $DEBUG;
1334         # parse the string in in operator/operand/value again
1335         $string =~ /(.*)(>=|<=)(.*)/;
1336         my $left = $1;
1337         my $operator = $2;
1338         my $right = $3;
1339         unless ($operator) {
1340             $string =~ /(.*)(>|<|=)(.*)/;
1341             $left = $1;
1342             $operator = $2;
1343             $right = $3;
1344         }
1345         my $results;
1346         # strip adv, zebra keywords, currently not handled in nozebra: wrdl, ext, phr...
1347         $left =~ s/[ ,].*$//;
1348         # automatic replace for short operators
1349         $left='title' if $left =~ '^ti$';
1350         $left='author' if $left =~ '^au$';
1351         $left='publisher' if $left =~ '^pb$';
1352         $left='subject' if $left =~ '^su$';
1353         $left='koha-Auth-Number' if $left =~ '^an$';
1354         $left='keyword' if $left =~ '^kw$';
1355         if ($operator && $left  ne 'keyword' ) {
1356             #do a specific search
1357             my $dbh = C4::Context->dbh;
1358             $operator='LIKE' if $operator eq '=' and $right=~ /%/;
1359             my $sth = $dbh->prepare("SELECT biblionumbers,value FROM nozebra WHERE server=? AND indexname=? AND value $operator ?");
1360             warn "$left / $operator / $right\n";
1361             # split each word, query the DB and build the biblionumbers result
1362             #sanitizing leftpart
1363             $left=~s/^\s+|\s+$//;
1364             my ($biblionumbers,$value);
1365             foreach (split / /,$right) {
1366                 next unless $_;
1367                 warn "EXECUTE : $server, $left, $_";
1368                 $sth->execute($server, $left, $_) or warn "execute failed: $!";
1369                 while (my ($line,$value) = $sth->fetchrow) {
1370                     # if we are dealing with a numeric value, use only numeric results (in case of >=, <=, > or <)
1371                     # otherwise, fill the result
1372                     $biblionumbers .= $line unless ($right =~ /\d/ && $value =~ /\D/);
1373 #                     warn "result : $value ". ($right =~ /\d/) . "==".(!$value =~ /\d/) ;#= $line";
1374                 }
1375                 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
1376                 if ($results) {
1377                     my @leftresult = split /;/, $biblionumbers;
1378                     my $temp;
1379                     foreach my $entry (@leftresult) { # $_ contains biblionumber,title-weight
1380                         # remove weight at the end
1381                         my $cleaned = $entry;
1382                         $cleaned =~ s/-\d*$//;
1383                         # if the entry already in the hash, take it & increase weight
1384                          warn "===== $cleaned =====" if $DEBUG;
1385                         if ($results =~ "$cleaned") {
1386                             $temp .= "$entry;$entry;";
1387                              warn "INCLUDING $entry" if $DEBUG;
1388                         }
1389                     }
1390                     $results = $temp;
1391                 } else {
1392                     $results = $biblionumbers;
1393                 }
1394             }
1395         } else {
1396             #do a complete search (all indexes), if index='kw' do complete search too.
1397             my $dbh = C4::Context->dbh;
1398             my $sth = $dbh->prepare("SELECT biblionumbers FROM nozebra WHERE server=? AND value LIKE ?");
1399             # split each word, query the DB and build the biblionumbers result
1400             foreach (split / /,$string) {
1401                 next if C4::Context->stopwords->{uc($_)}; # skip if stopword
1402                 warn "search on all indexes on $_" if $DEBUG;
1403                 my $biblionumbers;
1404                 next unless $_;
1405                 $sth->execute($server, $_);
1406                 while (my $line = $sth->fetchrow) {
1407                     $biblionumbers .= $line;
1408                 }
1409                 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
1410                 if ($results) {
1411                  warn "RES for $_ = $biblionumbers" if $DEBUG;
1412                     my @leftresult = split /;/, $biblionumbers;
1413                     my $temp;
1414                     foreach my $entry (@leftresult) { # $_ contains biblionumber,title-weight
1415                         # remove weight at the end
1416                         my $cleaned = $entry;
1417                         $cleaned =~ s/-\d*$//;
1418                         # if the entry already in the hash, take it & increase weight
1419                          warn "===== $cleaned =====" if $DEBUG;
1420                         if ($results =~ "$cleaned") {
1421                             $temp .= "$entry;$entry;";
1422                              warn "INCLUDING $entry" if $DEBUG;
1423                         }
1424                     }
1425                     $results = $temp;
1426                 } else {
1427                  warn "NEW RES for $_ = $biblionumbers" if $DEBUG;
1428                     $results = $biblionumbers;
1429                 }
1430             }
1431         }
1432          warn "return : $results for LEAF : $string" if $DEBUG;
1433         return $results;
1434     }
1435 }
1436
1437 =head2 NZorder
1438
1439   $finalresult = NZorder($biblionumbers, $ordering,$results_per_page,$offset);
1440
1441   TODO :: Description
1442
1443 =cut
1444
1445
1446 sub NZorder {
1447     my ($biblionumbers, $ordering,$results_per_page,$offset) = @_;
1448     warn "biblionumbers = $biblionumbers and ordering = $ordering\n" if $DEBUG;
1449     # order title asc by default
1450 #     $ordering = '1=36 <i' unless $ordering;
1451     $results_per_page=20 unless $results_per_page;
1452     $offset = 0 unless $offset;
1453     my $dbh = C4::Context->dbh;
1454     #
1455     # order by POPULARITY
1456     #
1457     if ($ordering =~ /popularity/) {
1458         my %result;
1459         my %popularity;
1460         # popularity is not in MARC record, it's builded from a specific query
1461         my $sth = $dbh->prepare("select sum(issues) from items where biblionumber=?");
1462         foreach (split /;/,$biblionumbers) {
1463             my ($biblionumber,$title) = split /,/,$_;
1464             $result{$biblionumber}=GetMarcBiblio($biblionumber);
1465             $sth->execute($biblionumber);
1466             my $popularity= $sth->fetchrow ||0;
1467             # hint : the key is popularity.title because we can have
1468             # many results with the same popularity. In this cas, sub-ordering is done by title
1469             # we also have biblionumber to avoid bug for 2 biblios with the same title & popularity
1470             # (un-frequent, I agree, but we won't forget anything that way ;-)
1471             $popularity{sprintf("%10d",$popularity).$title.$biblionumber} = $biblionumber;
1472         }
1473         # sort the hash and return the same structure as GetRecords (Zebra querying)
1474         my $result_hash;
1475         my $numbers=0;
1476         if ($ordering eq 'popularity_dsc') { # sort popularity DESC
1477             foreach my $key (sort {$b cmp $a} (keys %popularity)) {
1478                 $result_hash->{'RECORDS'}[$numbers++] = $result{$popularity{$key}}->as_usmarc();
1479             }
1480         } else { # sort popularity ASC
1481             foreach my $key (sort (keys %popularity)) {
1482                 $result_hash->{'RECORDS'}[$numbers++] = $result{$popularity{$key}}->as_usmarc();
1483             }
1484         }
1485         my $finalresult=();
1486         $result_hash->{'hits'} = $numbers;
1487         $finalresult->{'biblioserver'} = $result_hash;
1488         return $finalresult;
1489     #
1490     # ORDER BY author
1491     #
1492     } elsif ($ordering =~/author/){
1493         my %result;
1494         foreach (split /;/,$biblionumbers) {
1495             my ($biblionumber,$title) = split /,/,$_;
1496             my $record=GetMarcBiblio($biblionumber);
1497             my $author;
1498             if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1499                 $author=$record->subfield('200','f');
1500                 $author=$record->subfield('700','a') unless $author;
1501             } else {
1502                 $author=$record->subfield('100','a');
1503             }
1504             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1505             # and we don't want to get only 1 result for each of them !!!
1506             $result{$author.$biblionumber}=$record;
1507         }
1508         # sort the hash and return the same structure as GetRecords (Zebra querying)
1509         my $result_hash;
1510         my $numbers=0;
1511         if ($ordering eq 'author_za') { # sort by author desc
1512             foreach my $key (sort { $b cmp $a } (keys %result)) {
1513                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1514             }
1515         } else { # sort by author ASC
1516             foreach my $key (sort (keys %result)) {
1517                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1518             }
1519         }
1520         my $finalresult=();
1521         $result_hash->{'hits'} = $numbers;
1522         $finalresult->{'biblioserver'} = $result_hash;
1523         return $finalresult;
1524     #
1525     # ORDER BY callnumber
1526     #
1527     } elsif ($ordering =~/callnumber/){
1528         my %result;
1529         foreach (split /;/,$biblionumbers) {
1530             my ($biblionumber,$title) = split /,/,$_;
1531             my $record=GetMarcBiblio($biblionumber);
1532             my $callnumber;
1533             my ($callnumber_tag,$callnumber_subfield)=GetMarcFromKohaField($dbh,'items.itemcallnumber');
1534             ($callnumber_tag,$callnumber_subfield)= GetMarcFromKohaField('biblioitems.callnumber') unless $callnumber_tag;
1535             if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1536                 $callnumber=$record->subfield('200','f');
1537             } else {
1538                 $callnumber=$record->subfield('100','a');
1539             }
1540             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1541             # and we don't want to get only 1 result for each of them !!!
1542             $result{$callnumber.$biblionumber}=$record;
1543         }
1544         # sort the hash and return the same structure as GetRecords (Zebra querying)
1545         my $result_hash;
1546         my $numbers=0;
1547         if ($ordering eq 'call_number_dsc') { # sort by title desc
1548             foreach my $key (sort { $b cmp $a } (keys %result)) {
1549                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1550             }
1551         } else { # sort by title ASC
1552             foreach my $key (sort { $a cmp $b } (keys %result)) {
1553                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1554             }
1555         }
1556         my $finalresult=();
1557         $result_hash->{'hits'} = $numbers;
1558         $finalresult->{'biblioserver'} = $result_hash;
1559         return $finalresult;
1560     } elsif ($ordering =~ /pubdate/){ #pub year
1561         my %result;
1562         foreach (split /;/,$biblionumbers) {
1563             my ($biblionumber,$title) = split /,/,$_;
1564             my $record=GetMarcBiblio($biblionumber);
1565             my ($publicationyear_tag,$publicationyear_subfield)=GetMarcFromKohaField('biblioitems.publicationyear','');
1566             my $publicationyear=$record->subfield($publicationyear_tag,$publicationyear_subfield);
1567             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1568             # and we don't want to get only 1 result for each of them !!!
1569             $result{$publicationyear.$biblionumber}=$record;
1570         }
1571         # sort the hash and return the same structure as GetRecords (Zebra querying)
1572         my $result_hash;
1573         my $numbers=0;
1574         if ($ordering eq 'pubdate_dsc') { # sort by pubyear desc
1575             foreach my $key (sort { $b cmp $a } (keys %result)) {
1576                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1577             }
1578         } else { # sort by pub year ASC
1579             foreach my $key (sort (keys %result)) {
1580                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1581             }
1582         }
1583         my $finalresult=();
1584         $result_hash->{'hits'} = $numbers;
1585         $finalresult->{'biblioserver'} = $result_hash;
1586         return $finalresult;
1587     #
1588     # ORDER BY title
1589     #
1590     } elsif ($ordering =~ /title/) {
1591         # the title is in the biblionumbers string, so we just need to build a hash, sort it and return
1592         my %result;
1593         foreach (split /;/,$biblionumbers) {
1594             my ($biblionumber,$title) = split /,/,$_;
1595             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1596             # and we don't want to get only 1 result for each of them !!!
1597             # hint & speed improvement : we can order without reading the record
1598             # so order, and read records only for the requested page !
1599             $result{$title.$biblionumber}=$biblionumber;
1600         }
1601         # sort the hash and return the same structure as GetRecords (Zebra querying)
1602         my $result_hash;
1603         my $numbers=0;
1604         if ($ordering eq 'title_az') { # sort by title desc
1605             foreach my $key (sort (keys %result)) {
1606                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key};
1607             }
1608         } else { # sort by title ASC
1609             foreach my $key (sort { $b cmp $a } (keys %result)) {
1610                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key};
1611             }
1612         }
1613         # limit the $results_per_page to result size if it's more
1614         $results_per_page = $numbers-1 if $numbers < $results_per_page;
1615         # for the requested page, replace biblionumber by the complete record
1616         # speed improvement : avoid reading too much things
1617         for (my $counter=$offset;$counter<=$offset+$results_per_page;$counter++) {
1618             $result_hash->{'RECORDS'}[$counter] = GetMarcBiblio($result_hash->{'RECORDS'}[$counter])->as_usmarc;
1619         }
1620         my $finalresult=();
1621         $result_hash->{'hits'} = $numbers;
1622         $finalresult->{'biblioserver'} = $result_hash;
1623         return $finalresult;
1624     } else {
1625     #
1626     # order by ranking
1627     #
1628         # we need 2 hashes to order by ranking : the 1st one to count the ranking, the 2nd to order by ranking
1629         my %result;
1630         my %count_ranking;
1631         foreach (split /;/,$biblionumbers) {
1632             my ($biblionumber,$title) = split /,/,$_;
1633             $title =~ /(.*)-(\d)/;
1634             # get weight
1635             my $ranking =$2;
1636             # note that we + the ranking because ranking is calculated on weight of EACH term requested.
1637             # if we ask for "two towers", and "two" has weight 2 in biblio N, and "towers" has weight 4 in biblio N
1638             # biblio N has ranking = 6
1639             $count_ranking{$biblionumber} += $ranking;
1640         }
1641         # build the result by "inverting" the count_ranking hash
1642         # 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
1643 #         warn "counting";
1644         foreach (keys %count_ranking) {
1645             $result{sprintf("%10d",$count_ranking{$_}).'-'.$_} = $_;
1646         }
1647         # sort the hash and return the same structure as GetRecords (Zebra querying)
1648         my $result_hash;
1649         my $numbers=0;
1650             foreach my $key (sort {$b cmp $a} (keys %result)) {
1651                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key};
1652             }
1653         # limit the $results_per_page to result size if it's more
1654         $results_per_page = $numbers-1 if $numbers < $results_per_page;
1655         # for the requested page, replace biblionumber by the complete record
1656         # speed improvement : avoid reading too much things
1657         for (my $counter=$offset;$counter<=$offset+$results_per_page;$counter++) {
1658             $result_hash->{'RECORDS'}[$counter] = GetMarcBiblio($result_hash->{'RECORDS'}[$counter])->as_usmarc if $result_hash->{'RECORDS'}[$counter];
1659         }
1660         my $finalresult=();
1661         $result_hash->{'hits'} = $numbers;
1662         $finalresult->{'biblioserver'} = $result_hash;
1663         return $finalresult;
1664     }
1665 }
1666 =head2 ModBiblios
1667
1668 ($countchanged,$listunchanged) = ModBiblios($listbiblios, $tagsubfield,$initvalue,$targetvalue,$test);
1669
1670 this function changes all the values $initvalue in subfield $tag$subfield in any record in $listbiblios
1671 test parameter if set donot perform change to records in database.
1672
1673 =over 2
1674
1675 =item C<input arg:>
1676
1677     * $listbiblios is an array ref to marcrecords to be changed
1678     * $tagsubfield is the reference of the subfield to change.
1679     * $initvalue is the value to search the record for
1680     * $targetvalue is the value to set the subfield to
1681     * $test is to be set only not to perform changes in database.
1682
1683 =item C<Output arg:>
1684     * $countchanged counts all the changes performed.
1685     * $listunchanged contains the list of all the biblionumbers of records unchanged.
1686
1687 =item C<usage in the script:>
1688
1689 =back
1690
1691 my ($countchanged, $listunchanged) = EditBiblios($results->{RECORD}, $tagsubfield,$initvalue,$targetvalue);;
1692 #If one wants to display unchanged records, you should get biblios foreach @$listunchanged
1693 $template->param(countchanged => $countchanged, loopunchanged=>$listunchanged);
1694
1695 =cut
1696
1697 sub ModBiblios{
1698   my ($listbiblios,$tagsubfield,$initvalue,$targetvalue,$test)=@_;
1699   my $countmatched;
1700   my @unmatched;
1701   my ($tag,$subfield)=($1,$2) if ($tagsubfield=~/^(\d{1,3})([a-z0-9A-Z@])?$/);
1702   if ((length($tag)<3)&& $subfield=~/0-9/){
1703     $tag=$tag.$subfield;
1704     undef $subfield;
1705   }
1706   my ($bntag,$bnsubf) = GetMarcFromKohaField('biblio.biblionumber');
1707   my ($itemtag,$itemsubf) = GetMarcFromKohaField('items.itemnumber');
1708   foreach my $usmarc (@$listbiblios){
1709     my $record;
1710     $record=eval{MARC::Record->new_from_usmarc($usmarc)};
1711     my $biblionumber;
1712     if ($@){
1713       # usmarc is not a valid usmarc May be a biblionumber
1714       if ($tag eq $itemtag){
1715         my $bib=GetBiblioFromItemNumber($usmarc);
1716         $record=GetMarcItem($bib->{'biblionumber'},$usmarc) ;
1717         $biblionumber=$bib->{'biblionumber'};
1718       } else {
1719         $record=GetMarcBiblio($usmarc);
1720         $biblionumber=$usmarc;
1721       }
1722     }  else {
1723       if ($bntag >= 010){
1724         $biblionumber = $record->subfield($bntag,$bnsubf);
1725       }else {
1726         $biblionumber=$record->field($bntag)->data;
1727       }
1728     }
1729     #GetBiblionumber is to be written.
1730     #Could be replaced by TransformMarcToKoha (But Would be longer)
1731     if ($record->field($tag)){
1732       my $modify=0;
1733       foreach my $field ($record->field($tag)){
1734         if ($subfield){
1735           if ($field->delete_subfield('code' =>$subfield,'match'=>qr($initvalue))){
1736             $countmatched++;
1737             $modify=1;
1738             $field->update($subfield,$targetvalue) if ($targetvalue);
1739           }
1740         } else {
1741           if ($tag >= 010){
1742             if ($field->delete_field($field)){
1743               $countmatched++;
1744               $modify=1;
1745             }
1746           } else {
1747             $field->data=$targetvalue if ($field->data=~qr($initvalue));
1748           }
1749         }
1750       }
1751 #       warn $record->as_formatted;
1752       if ($modify){
1753         ModBiblio($record,$biblionumber,GetFrameworkCode($biblionumber)) unless ($test);
1754       } else {
1755         push @unmatched, $biblionumber;
1756       }
1757     } else {
1758       push @unmatched, $biblionumber;
1759     }
1760   }
1761   return ($countmatched,\@unmatched);
1762 }
1763
1764 END { }    # module clean-up code here (global destructor)
1765
1766 1;
1767 __END__
1768
1769 =head1 AUTHOR
1770
1771 Koha Developement team <info@koha.org>
1772
1773 =cut