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