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