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