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.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 gt 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         $oldbiblio->{'author_nospan'} = $oldbiblio->{'author'};
1056         foreach my $term ( keys %$span_terms_hashref ) {
1057             my $old_term = $term;
1058             if ( length($term) > 3 ) {
1059                 $term =~ s/(.*=|\)|\(|\+|\.|\?|\[|\])//g;
1060                 $term =~ s/\\//g;
1061                 $term =~ s/\*//g;
1062
1063                 #FIXME: is there a better way to do this?
1064                 $oldbiblio->{'title'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1065                 $oldbiblio->{'subtitle'} =~
1066                   s/$term/<span class=\"term\">$&<\/span>/gi;
1067
1068                 $oldbiblio->{'author'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1069                 $oldbiblio->{'publishercode'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1070                 $oldbiblio->{'place'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1071                 $oldbiblio->{'pages'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1072                 $oldbiblio->{'notes'} =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1073                 $oldbiblio->{'size'}  =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1074             }
1075         }
1076
1077         if ( $i % 2 ) {
1078             $toggle = "#ffffcc";
1079         }
1080         else {
1081             $toggle = "white";
1082         }
1083         $oldbiblio->{'toggle'} = $toggle;
1084         my @fields = $marcrecord->field($itemtag);
1085         my @items_loop;
1086         my $items;
1087         my $ordered_count     = 0;
1088         my $onloan_count      = 0;
1089         my $wthdrawn_count    = 0;
1090         my $itemlost_count    = 0;
1091         my $norequests        = 1;
1092
1093         #
1094         # check the loan status of the item :
1095         # it is not stored in the MARC record, for pref (zebra reindexing)
1096         # reason. Thus, we have to get the status from a specific SQL query
1097         #
1098         my $sth_issue = $dbh->prepare("
1099             SELECT date_due,returndate
1100             FROM issues
1101             WHERE itemnumber=? AND returndate IS NULL");
1102         my $items_count=scalar(@fields);
1103         foreach my $field (@fields) {
1104             my $item;
1105             foreach my $code ( keys %subfieldstosearch ) {
1106                 $item->{$code} = $field->subfield( $subfieldstosearch{$code} );
1107             }
1108             $sth_issue->execute($item->{itemnumber});
1109             $item->{due_date} = format_date($sth_issue->fetchrow) if $sth_issue->fetchrow;
1110             $item->{onloan} = 1 if $item->{due_date};
1111             # at least one item can be reserved : suppose no
1112             $norequests = 1;
1113             if ( $item->{wthdrawn} ) {
1114                 $wthdrawn_count++;
1115                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{unavailable}=1;
1116                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{wthdrawn}=1;
1117             }
1118             elsif ( $item->{itemlost} ) {
1119                 $itemlost_count++;
1120                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{unavailable}=1;
1121                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{itemlost}=1;
1122             }
1123             unless ( $item->{notforloan}) {
1124                 # OK, this one can be issued, so at least one can be reserved
1125                 $norequests = 0;
1126             }
1127             if ( ( $item->{onloan} ) && ( $item->{onloan} != '0000-00-00' ) )
1128             {
1129                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{unavailable}=1;
1130                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{onloancount} = 1;
1131                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{due_date} = $item->{due_date};
1132                 $onloan_count++;
1133             }
1134             if ( $item->{'homebranch'} ) {
1135                 $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{count}++;
1136             }
1137
1138             # Last resort
1139             elsif ( $item->{'holdingbranch'} ) {
1140                 $items->{ $item->{'holdingbranch'} }->{count}++;
1141             }
1142             $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{itemcallnumber} =                $item->{itemcallnumber};
1143             $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{location} =                $item->{location};
1144             $items->{ $item->{'homebranch'}.'--'.$item->{'itemcallnumber'} }->{branchcode} =               $item->{homebranch};
1145         }    # notforloan, item level and biblioitem level
1146
1147         # last check for norequest : if itemtype is notforloan, it can't be reserved either, whatever the items
1148         $norequests = 1 if $itemtypes{$oldbiblio->{itemtype}}->{notforloan};
1149                 my $itemscount;
1150         for my $key ( sort keys %$items ) {
1151                         $itemscount++;
1152             my $this_item = {
1153                 branchname     => $branches{$items->{$key}->{branchcode}},
1154                 branchcode     => $items->{$key}->{branchcode},
1155                 count          => $items->{$key}->{count},
1156                 itemcallnumber => $items->{$key}->{itemcallnumber},
1157                 location => $items->{$key}->{location},
1158                 onloancount      => $items->{$key}->{onloancount},
1159                 due_date         => $items->{$key}->{due_date},
1160                 wthdrawn      => $items->{$key}->{wthdrawn},
1161                 lost         => $items->{$key}->{itemlost},
1162             };
1163                         # only show the number specified by the user
1164                         my $maxitems = (C4::Context->preference('maxItemsinSearchResults')) ? C4::Context->preference('maxItemsinSearchResults')- 1 : 1;
1165             push @items_loop, $this_item unless $itemscount > $maxitems;;
1166         }
1167         $oldbiblio->{norequests}    = $norequests;
1168         $oldbiblio->{items_count}    = $items_count;
1169         $oldbiblio->{items_loop}    = \@items_loop;
1170         $oldbiblio->{onloancount}   = $onloan_count;
1171         $oldbiblio->{wthdrawncount} = $wthdrawn_count;
1172         $oldbiblio->{itemlostcount} = $itemlost_count;
1173         $oldbiblio->{orderedcount}  = $ordered_count;
1174         $oldbiblio->{isbn}          =~ s/-//g; # deleting - in isbn to enable amazon content
1175         push( @newresults, $oldbiblio );
1176     }
1177     return @newresults;
1178 }
1179
1180
1181
1182 #----------------------------------------------------------------------
1183 #
1184 # Non-Zebra GetRecords#
1185 #----------------------------------------------------------------------
1186
1187 =head2 NZgetRecords
1188
1189   NZgetRecords has the same API as zera getRecords, even if some parameters are not managed
1190
1191 =cut
1192 sub NZgetRecords {
1193     my ($query,$simple_query,$sort_by_ref,$servers_ref,$results_per_page,$offset,$expanded_facet,$branches,$query_type,$scan) = @_;
1194     my $result = NZanalyse($query);
1195     return (undef,NZorder($result,@$sort_by_ref[0],$results_per_page,$offset),undef);
1196 }
1197
1198 =head2 NZanalyse
1199
1200   NZanalyse : get a CQL string as parameter, and returns a list of biblionumber;title,biblionumber;title,...
1201   the list is built from an inverted index in the nozebra SQL table
1202   note that title is here only for convenience : the sorting will be very fast when requested on title
1203   if the sorting is requested on something else, we will have to reread all results, and that may be longer.
1204
1205 =cut
1206
1207 sub NZanalyse {
1208     my ($string,$server) = @_;
1209     # $server contains biblioserver or authorities, depending on what we search on.
1210     #warn "querying : $string on $server";
1211     $server='biblioserver' unless $server;
1212
1213     # if we have a ", replace the content to discard temporarily any and/or/not inside
1214     my $commacontent;
1215     if ($string =~/"/) {
1216         $string =~ s/"(.*?)"/__X__/;
1217         $commacontent = $1;
1218                 warn "commacontent : $commacontent" if $DEBUG;
1219     }
1220     # split the query string in 3 parts : X AND Y means : $left="X", $operand="AND" and $right="Y"
1221     # then, call again NZanalyse with $left and $right
1222     # (recursive until we find a leaf (=> something without and/or/not)
1223     # delete repeated operator... Would then go in infinite loop
1224     while ($string =~s/( and| or| not| AND| OR| NOT)\1/$1/g){
1225     }
1226     #process parenthesis before.
1227     if ($string =~ /^\s*\((.*)\)(( and | or | not | AND | OR | NOT )(.*))?/){
1228       my $left = $1;
1229 #       warn "left :".$left;
1230       my $right = $4;
1231       my $operator = lc($3); # FIXME: and/or/not are operators, not operands
1232       my $leftresult = NZanalyse($left,$server);
1233       if ($operator) {
1234         my $rightresult = NZanalyse($right,$server);
1235         # OK, we have the results for right and left part of the query
1236         # depending of operand, intersect, union or exclude both lists
1237         # to get a result list
1238         if ($operator eq ' and ') {
1239             my @leftresult = split /;/, $leftresult;
1240 #             my @rightresult = split /;/,$leftresult;
1241             my $finalresult;
1242             # parse the left results, and if the biblionumber exist in the right result, save it in finalresult
1243             # the result is stored twice, to have the same weight for AND than OR.
1244             # example : TWO : 61,61,64,121 (two is twice in the biblio #61) / TOWER : 61,64,130
1245             # result : 61,61,61,61,64,64 for two AND tower : 61 has more weight than 64
1246             foreach (@leftresult) {
1247                 if ($rightresult =~ "$_;") {
1248                     $finalresult .= "$_;$_;";
1249                 }
1250             }
1251             return $finalresult;
1252         } elsif ($operator eq ' or ') {
1253             # just merge the 2 strings
1254             return $leftresult.$rightresult;
1255         } elsif ($operator eq ' not ') {
1256             my @leftresult = split /;/, $leftresult;
1257 #             my @rightresult = split /;/,$leftresult;
1258             my $finalresult;
1259             foreach (@leftresult) {
1260                 unless ($rightresult =~ "$_;") {
1261                     $finalresult .= "$_;";
1262                 }
1263             }
1264             return $finalresult;
1265         } else {
1266             # this error is impossible, because of the regexp that isolate the operand, but just in case...
1267             return $leftresult;
1268             exit;
1269         }
1270       }
1271     }
1272     warn "string :".$string if $DEBUG;
1273     $string =~ /(.*?)( and | or | not | AND | OR | NOT )(.*)/;
1274     my $left = $1;
1275     my $right = $3;
1276     my $operand = lc($2); # FIXME: and/or/not are operators, not operands
1277     # it's not a leaf, we have a and/or/not
1278     if ($operand) {
1279         # reintroduce comma content if needed
1280         $right =~ s/__X__/"$commacontent"/ if $commacontent;
1281         $left =~ s/__X__/"$commacontent"/ if $commacontent;
1282         warn "node : $left / $operand / $right\n" if $DEBUG;
1283         my $leftresult = NZanalyse($left,$server);
1284         my $rightresult = NZanalyse($right,$server);
1285         # OK, we have the results for right and left part of the query
1286         # depending of operand, intersect, union or exclude both lists
1287         # to get a result list
1288         if ($operand eq ' and ') {
1289             my @leftresult = split /;/, $leftresult;
1290 #             my @rightresult = split /;/,$leftresult;
1291             my $finalresult;
1292             # parse the left results, and if the biblionumber exist in the right result, save it in finalresult
1293             # the result is stored twice, to have the same weight for AND than OR.
1294             # example : TWO : 61,61,64,121 (two is twice in the biblio #61) / TOWER : 61,64,130
1295             # result : 61,61,61,61,64,64 for two AND tower : 61 has more weight than 64
1296             foreach (@leftresult) {
1297                 if ($rightresult =~ "$_;") {
1298                     $finalresult .= "$_;$_;";
1299                 }
1300             }
1301             return $finalresult;
1302         } elsif ($operand eq ' or ') {
1303             # just merge the 2 strings
1304             return $leftresult.$rightresult;
1305         } elsif ($operand eq ' not ') {
1306             my @leftresult = split /;/, $leftresult;
1307 #             my @rightresult = split /;/,$leftresult;
1308             my $finalresult;
1309             foreach (@leftresult) {
1310                 unless ($rightresult =~ "$_;") {
1311                     $finalresult .= "$_;";
1312                 }
1313             }
1314             return $finalresult;
1315         } else {
1316             # this error is impossible, because of the regexp that isolate the operand, but just in case...
1317             die "error : operand unknown : $operand for $string";
1318         }
1319     # it's a leaf, do the real SQL query and return the result
1320     } else {
1321         $string =~  s/__X__/"$commacontent"/ if $commacontent;
1322         $string =~ s/-|\.|\?|,|;|!|'|\(|\)|\[|\]|{|}|"|&|\+|\*|\// /g;
1323         warn "leaf : $string\n" if $DEBUG;
1324         # parse the string in in operator/operand/value again
1325         $string =~ /(.*)(>=|<=)(.*)/;
1326         my $left = $1;
1327         my $operator = $2;
1328         my $right = $3;
1329         unless ($operator) {
1330             $string =~ /(.*)(>|<|=)(.*)/;
1331             $left = $1;
1332             $operator = $2;
1333             $right = $3;
1334         }
1335         my $results;
1336         # strip adv, zebra keywords, currently not handled in nozebra: wrdl, ext, phr...
1337         $left =~ s/[ ,].*$//;
1338         # automatic replace for short operators
1339         $left='title' if $left =~ '^ti$';
1340         $left='author' if $left =~ '^au$';
1341         $left='publisher' if $left =~ '^pb$';
1342         $left='subject' if $left =~ '^su$';
1343         $left='koha-Auth-Number' if $left =~ '^an$';
1344         $left='keyword' if $left =~ '^kw$';
1345         if ($operator) {
1346             #do a specific search
1347             my $dbh = C4::Context->dbh;
1348             $operator='LIKE' if $operator eq '=' and $right=~ /%/;
1349             my $sth = $dbh->prepare("SELECT biblionumbers,value FROM nozebra WHERE server=? AND indexname=? AND value $operator ?");
1350             warn "$left / $operator / $right\n";
1351             # split each word, query the DB and build the biblionumbers result
1352             #sanitizing leftpart
1353             $left=~s/^\s+|\s+$//;
1354             my ($biblionumbers,$value);
1355             foreach (split / /,$right) {
1356                 next unless $_;
1357                 warn "EXECUTE : $server, $left, $_";
1358                 $sth->execute($server, $left, $_) or warn "execute failed: $!";
1359                 while (my ($line,$value) = $sth->fetchrow) {
1360                     # if we are dealing with a numeric value, use only numeric results (in case of >=, <=, > or <)
1361                     # otherwise, fill the result
1362                     $biblionumbers .= $line unless ($right =~ /\d/ && $value =~ /\D/);
1363 #                     warn "result : $value ". ($right =~ /\d/) . "==".(!$value =~ /\d/) ;#= $line";
1364                 }
1365                 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
1366                 if ($results) {
1367                     my @leftresult = split /;/, $biblionumbers;
1368                     my $temp;
1369                     foreach my $entry (@leftresult) { # $_ contains biblionumber,title-weight
1370                         # remove weight at the end
1371                         my $cleaned = $entry;
1372                         $cleaned =~ s/-\d*$//;
1373                         # if the entry already in the hash, take it & increase weight
1374                          warn "===== $cleaned =====" if $DEBUG;
1375                         if ($results =~ "$cleaned") {
1376                             $temp .= "$entry;$entry;";
1377                              warn "INCLUDING $entry" if $DEBUG;
1378                         }
1379                     }
1380                     $results = $temp;
1381                 } else {
1382                     $results = $biblionumbers;
1383                 }
1384             }
1385         } else {
1386             #do a complete search (all indexes)
1387             my $dbh = C4::Context->dbh;
1388             my $sth = $dbh->prepare("SELECT biblionumbers FROM nozebra WHERE server=? AND value LIKE ?");
1389             # split each word, query the DB and build the biblionumbers result
1390             foreach (split / /,$string) {
1391                 next if C4::Context->stopwords->{uc($_)}; # skip if stopword
1392                 warn "search on all indexes on $_" if $DEBUG;
1393                 my $biblionumbers;
1394                 next unless $_;
1395                 $sth->execute($server, $_);
1396                 while (my $line = $sth->fetchrow) {
1397                     $biblionumbers .= $line;
1398                 }
1399                 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
1400                 if ($results) {
1401                  warn "RES for $_ = $biblionumbers" if $DEBUG;
1402                     my @leftresult = split /;/, $biblionumbers;
1403                     my $temp;
1404                     foreach my $entry (@leftresult) { # $_ contains biblionumber,title-weight
1405                         # remove weight at the end
1406                         my $cleaned = $entry;
1407                         $cleaned =~ s/-\d*$//;
1408                         # if the entry already in the hash, take it & increase weight
1409                          warn "===== $cleaned =====" if $DEBUG;
1410                         if ($results =~ "$cleaned") {
1411                             $temp .= "$entry;$entry;";
1412                              warn "INCLUDING $entry" if $DEBUG;
1413                         }
1414                     }
1415                     $results = $temp;
1416                 } else {
1417                  warn "NEW RES for $_ = $biblionumbers" if $DEBUG;
1418                     $results = $biblionumbers;
1419                 }
1420             }
1421         }
1422 #         warn "return : $results for LEAF : $string" if $DEBUG;
1423         return $results;
1424     }
1425 }
1426
1427 =head2 NZorder
1428
1429   $finalresult = NZorder($biblionumbers, $ordering,$results_per_page,$offset);
1430
1431   TODO :: Description
1432
1433 =cut
1434
1435
1436 sub NZorder {
1437     my ($biblionumbers, $ordering,$results_per_page,$offset) = @_;
1438     # order title asc by default
1439 #     $ordering = '1=36 <i' unless $ordering;
1440     $results_per_page=20 unless $results_per_page;
1441     $offset = 0 unless $offset;
1442     my $dbh = C4::Context->dbh;
1443     #
1444     # order by POPULARITY
1445     #
1446     if ($ordering =~ /popularity/) {
1447         my %result;
1448         my %popularity;
1449         # popularity is not in MARC record, it's builded from a specific query
1450         my $sth = $dbh->prepare("select sum(issues) from items where biblionumber=?");
1451         foreach (split /;/,$biblionumbers) {
1452             my ($biblionumber,$title) = split /,/,$_;
1453             $result{$biblionumber}=GetMarcBiblio($biblionumber);
1454             $sth->execute($biblionumber);
1455             my $popularity= $sth->fetchrow ||0;
1456             # hint : the key is popularity.title because we can have
1457             # many results with the same popularity. In this cas, sub-ordering is done by title
1458             # we also have biblionumber to avoid bug for 2 biblios with the same title & popularity
1459             # (un-frequent, I agree, but we won't forget anything that way ;-)
1460             $popularity{sprintf("%10d",$popularity).$title.$biblionumber} = $biblionumber;
1461         }
1462         # sort the hash and return the same structure as GetRecords (Zebra querying)
1463         my $result_hash;
1464         my $numbers=0;
1465         if ($ordering eq 'popularity_dsc') { # sort popularity DESC
1466             foreach my $key (sort {$b cmp $a} (keys %popularity)) {
1467                 $result_hash->{'RECORDS'}[$numbers++] = $result{$popularity{$key}}->as_usmarc();
1468             }
1469         } else { # sort popularity ASC
1470             foreach my $key (sort (keys %popularity)) {
1471                 $result_hash->{'RECORDS'}[$numbers++] = $result{$popularity{$key}}->as_usmarc();
1472             }
1473         }
1474         my $finalresult=();
1475         $result_hash->{'hits'} = $numbers;
1476         $finalresult->{'biblioserver'} = $result_hash;
1477         return $finalresult;
1478     #
1479     # ORDER BY author
1480     #
1481     } elsif ($ordering =~/author/){
1482         my %result;
1483         foreach (split /;/,$biblionumbers) {
1484             my ($biblionumber,$title) = split /,/,$_;
1485             my $record=GetMarcBiblio($biblionumber);
1486             my $author;
1487             if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1488                 $author=$record->subfield('200','f');
1489                 $author=$record->subfield('700','a') unless $author;
1490             } else {
1491                 $author=$record->subfield('100','a');
1492             }
1493             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1494             # and we don't want to get only 1 result for each of them !!!
1495             $result{$author.$biblionumber}=$record;
1496         }
1497         # sort the hash and return the same structure as GetRecords (Zebra querying)
1498         my $result_hash;
1499         my $numbers=0;
1500         if ($ordering eq 'author_za') { # sort by author desc
1501             foreach my $key (sort { $b cmp $a } (keys %result)) {
1502                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1503             }
1504         } else { # sort by author ASC
1505             foreach my $key (sort (keys %result)) {
1506                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1507             }
1508         }
1509         my $finalresult=();
1510         $result_hash->{'hits'} = $numbers;
1511         $finalresult->{'biblioserver'} = $result_hash;
1512         return $finalresult;
1513     #
1514     # ORDER BY callnumber
1515     #
1516     } elsif ($ordering =~/callnumber/){
1517         my %result;
1518         foreach (split /;/,$biblionumbers) {
1519             my ($biblionumber,$title) = split /,/,$_;
1520             my $record=GetMarcBiblio($biblionumber);
1521             my $callnumber;
1522             my ($callnumber_tag,$callnumber_subfield)=GetMarcFromKohaField($dbh,'items.itemcallnumber');
1523             ($callnumber_tag,$callnumber_subfield)= GetMarcFromKohaField('biblioitems.callnumber') unless $callnumber_tag;
1524             if (C4::Context->preference('marcflavour') eq 'UNIMARC') {
1525                 $callnumber=$record->subfield('200','f');
1526             } else {
1527                 $callnumber=$record->subfield('100','a');
1528             }
1529             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1530             # and we don't want to get only 1 result for each of them !!!
1531             $result{$callnumber.$biblionumber}=$record;
1532         }
1533         # sort the hash and return the same structure as GetRecords (Zebra querying)
1534         my $result_hash;
1535         my $numbers=0;
1536         if ($ordering eq 'call_number_dsc') { # sort by title desc
1537             foreach my $key (sort { $b cmp $a } (keys %result)) {
1538                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1539             }
1540         } else { # sort by title ASC
1541             foreach my $key (sort { $a cmp $b } (keys %result)) {
1542                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1543             }
1544         }
1545         my $finalresult=();
1546         $result_hash->{'hits'} = $numbers;
1547         $finalresult->{'biblioserver'} = $result_hash;
1548         return $finalresult;
1549     } elsif ($ordering =~ /pubdate/){ #pub year
1550         my %result;
1551         foreach (split /;/,$biblionumbers) {
1552             my ($biblionumber,$title) = split /,/,$_;
1553             my $record=GetMarcBiblio($biblionumber);
1554             my ($publicationyear_tag,$publicationyear_subfield)=GetMarcFromKohaField('biblioitems.publicationyear','');
1555             my $publicationyear=$record->subfield($publicationyear_tag,$publicationyear_subfield);
1556             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1557             # and we don't want to get only 1 result for each of them !!!
1558             $result{$publicationyear.$biblionumber}=$record;
1559         }
1560         # sort the hash and return the same structure as GetRecords (Zebra querying)
1561         my $result_hash;
1562         my $numbers=0;
1563         if ($ordering eq 'pubdate_dsc') { # sort by pubyear desc
1564             foreach my $key (sort { $b cmp $a } (keys %result)) {
1565                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1566             }
1567         } else { # sort by pub year ASC
1568             foreach my $key (sort (keys %result)) {
1569                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key}->as_usmarc();
1570             }
1571         }
1572         my $finalresult=();
1573         $result_hash->{'hits'} = $numbers;
1574         $finalresult->{'biblioserver'} = $result_hash;
1575         return $finalresult;
1576     #
1577     # ORDER BY title
1578     #
1579     } elsif ($ordering =~ /title/) {
1580         # the title is in the biblionumbers string, so we just need to build a hash, sort it and return
1581         my %result;
1582         foreach (split /;/,$biblionumbers) {
1583             my ($biblionumber,$title) = split /,/,$_;
1584             # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1585             # and we don't want to get only 1 result for each of them !!!
1586             # hint & speed improvement : we can order without reading the record
1587             # so order, and read records only for the requested page !
1588             $result{$title.$biblionumber}=$biblionumber;
1589         }
1590         # sort the hash and return the same structure as GetRecords (Zebra querying)
1591         my $result_hash;
1592         my $numbers=0;
1593         if ($ordering eq 'title_az') { # sort by title desc
1594             foreach my $key (sort (keys %result)) {
1595                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key};
1596             }
1597         } else { # sort by title ASC
1598             foreach my $key (sort { $b cmp $a } (keys %result)) {
1599                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key};
1600             }
1601         }
1602         # limit the $results_per_page to result size if it's more
1603         $results_per_page = $numbers-1 if $numbers < $results_per_page;
1604         # for the requested page, replace biblionumber by the complete record
1605         # speed improvement : avoid reading too much things
1606         for (my $counter=$offset;$counter<=$offset+$results_per_page;$counter++) {
1607             $result_hash->{'RECORDS'}[$counter] = GetMarcBiblio($result_hash->{'RECORDS'}[$counter])->as_usmarc;
1608         }
1609         my $finalresult=();
1610         $result_hash->{'hits'} = $numbers;
1611         $finalresult->{'biblioserver'} = $result_hash;
1612         return $finalresult;
1613     } else {
1614     #
1615     # order by ranking
1616     #
1617         # we need 2 hashes to order by ranking : the 1st one to count the ranking, the 2nd to order by ranking
1618         my %result;
1619         my %count_ranking;
1620         foreach (split /;/,$biblionumbers) {
1621             my ($biblionumber,$title) = split /,/,$_;
1622             $title =~ /(.*)-(\d)/;
1623             # get weight
1624             my $ranking =$2;
1625             # note that we + the ranking because ranking is calculated on weight of EACH term requested.
1626             # if we ask for "two towers", and "two" has weight 2 in biblio N, and "towers" has weight 4 in biblio N
1627             # biblio N has ranking = 6
1628             $count_ranking{$biblionumber} += $ranking;
1629         }
1630         # build the result by "inverting" the count_ranking hash
1631         # 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
1632 #         warn "counting";
1633         foreach (keys %count_ranking) {
1634             $result{sprintf("%10d",$count_ranking{$_}).'-'.$_} = $_;
1635         }
1636         # sort the hash and return the same structure as GetRecords (Zebra querying)
1637         my $result_hash;
1638         my $numbers=0;
1639             foreach my $key (sort {$b cmp $a} (keys %result)) {
1640                 $result_hash->{'RECORDS'}[$numbers++] = $result{$key};
1641             }
1642         # limit the $results_per_page to result size if it's more
1643         $results_per_page = $numbers-1 if $numbers < $results_per_page;
1644         # for the requested page, replace biblionumber by the complete record
1645         # speed improvement : avoid reading too much things
1646         for (my $counter=$offset;$counter<=$offset+$results_per_page;$counter++) {
1647             $result_hash->{'RECORDS'}[$counter] = GetMarcBiblio($result_hash->{'RECORDS'}[$counter])->as_usmarc if $result_hash->{'RECORDS'}[$counter];
1648         }
1649         my $finalresult=();
1650         $result_hash->{'hits'} = $numbers;
1651         $finalresult->{'biblioserver'} = $result_hash;
1652         return $finalresult;
1653     }
1654 }
1655 =head2 ModBiblios
1656
1657 ($countchanged,$listunchanged) = ModBiblios($listbiblios, $tagsubfield,$initvalue,$targetvalue,$test);
1658
1659 this function changes all the values $initvalue in subfield $tag$subfield in any record in $listbiblios
1660 test parameter if set donot perform change to records in database.
1661
1662 =over 2
1663
1664 =item C<input arg:>
1665
1666     * $listbiblios is an array ref to marcrecords to be changed
1667     * $tagsubfield is the reference of the subfield to change.
1668     * $initvalue is the value to search the record for
1669     * $targetvalue is the value to set the subfield to
1670     * $test is to be set only not to perform changes in database.
1671
1672 =item C<Output arg:>
1673     * $countchanged counts all the changes performed.
1674     * $listunchanged contains the list of all the biblionumbers of records unchanged.
1675
1676 =item C<usage in the script:>
1677
1678 =back
1679
1680 my ($countchanged, $listunchanged) = EditBiblios($results->{RECORD}, $tagsubfield,$initvalue,$targetvalue);;
1681 #If one wants to display unchanged records, you should get biblios foreach @$listunchanged
1682 $template->param(countchanged => $countchanged, loopunchanged=>$listunchanged);
1683
1684 =cut
1685
1686 sub ModBiblios{
1687   my ($listbiblios,$tagsubfield,$initvalue,$targetvalue,$test)=@_;
1688   my $countmatched;
1689   my @unmatched;
1690   my ($tag,$subfield)=($1,$2) if ($tagsubfield=~/^(\d{1,3})([a-z0-9A-Z@])?$/);
1691   if ((length($tag)<3)&& $subfield=~/0-9/){
1692     $tag=$tag.$subfield;
1693     undef $subfield;
1694   }
1695   my ($bntag,$bnsubf) = GetMarcFromKohaField('biblio.biblionumber');
1696   my ($itemtag,$itemsubf) = GetMarcFromKohaField('items.itemnumber');
1697   foreach my $usmarc (@$listbiblios){
1698     my $record;
1699     $record=eval{MARC::Record->new_from_usmarc($usmarc)};
1700     my $biblionumber;
1701     if ($@){
1702       # usmarc is not a valid usmarc May be a biblionumber
1703       if ($tag eq $itemtag){
1704         my $bib=GetBiblioFromItemNumber($usmarc);
1705         $record=GetMarcItem($bib->{'biblionumber'},$usmarc) ;
1706         $biblionumber=$bib->{'biblionumber'};
1707       } else {
1708         $record=GetMarcBiblio($usmarc);
1709         $biblionumber=$usmarc;
1710       }
1711     }  else {
1712       if ($bntag >= 010){
1713         $biblionumber = $record->subfield($bntag,$bnsubf);
1714       }else {
1715         $biblionumber=$record->field($bntag)->data;
1716       }
1717     }
1718     #GetBiblionumber is to be written.
1719     #Could be replaced by TransformMarcToKoha (But Would be longer)
1720     if ($record->field($tag)){
1721       my $modify=0;
1722       foreach my $field ($record->field($tag)){
1723         if ($subfield){
1724           if ($field->delete_subfield('code' =>$subfield,'match'=>qr($initvalue))){
1725             $countmatched++;
1726             $modify=1;
1727             $field->update($subfield,$targetvalue) if ($targetvalue);
1728           }
1729         } else {
1730           if ($tag >= 010){
1731             if ($field->delete_field($field)){
1732               $countmatched++;
1733               $modify=1;
1734             }
1735           } else {
1736             $field->data=$targetvalue if ($field->data=~qr($initvalue));
1737           }
1738         }
1739       }
1740 #       warn $record->as_formatted;
1741       if ($modify){
1742         ModBiblio($record,$biblionumber,GetFrameworkCode($biblionumber)) unless ($test);
1743       } else {
1744         push @unmatched, $biblionumber;
1745       }
1746     } else {
1747       push @unmatched, $biblionumber;
1748     }
1749   }
1750   return ($countmatched,\@unmatched);
1751 }
1752
1753 END { }    # module clean-up code here (global destructor)
1754
1755 1;
1756 __END__
1757
1758 =head1 AUTHOR
1759
1760 Koha Developement team <info@koha.org>
1761
1762 =cut