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