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 #use warnings; FIXME - Bug 2505
  20 require Exporter;
  21 use C4::Context;
  22 use C4::Biblio;    # GetMarcFromKohaField, GetBiblioData
  23 use C4::Koha;      # getFacets
  24 use Lingua::Stem;
  25 use C4::Search::PazPar2;
  26 use XML::Simple;
  27 use C4::Dates qw(format_date);
  28 use C4::Members qw(GetHideLostItemsPreference);
  29 use C4::XSLT;
  30 use C4::Branch;
  31 use C4::Reserves;    # GetReserveStatus
  32 use C4::Debug;
  33 use C4::Charset;
  34 use YAML;
  35 use URI::Escape;
  36 use Business::ISBN;
  37 use MARC::Record;
  38 use MARC::Field;
  39 use utf8;
  40 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
  41
  42 # set the version for version checking
  43 BEGIN {
  44     $VERSION = 3.07.00.049;
  45     $DEBUG = ($ENV{DEBUG}) ? 1 : 0;
  46 }
  47
  48 =head1 NAME
  49
  50 C4::Search - Functions for searching the Koha catalog.
  51
  52 =head1 SYNOPSIS
  53
  54 See opac/opac-search.pl or catalogue/search.pl for example of usage
  55
  56 =head1 DESCRIPTION
  57
  58 This module provides searching functions for Koha's bibliographic databases
  59
  60 =head1 FUNCTIONS
  61
  62 =cut
  63
  64 @ISA    = qw(Exporter);
  65 @EXPORT = qw(
  66   &FindDuplicate
  67   &SimpleSearch
  68   &searchResults
  69   &getRecords
  70   &buildQuery
  71   &GetDistinctValues
  72   &enabled_staff_search_views
  73   &PurgeSearchHistory
  74 );
  75
  76 # make all your functions, whether exported or not;
  77
  78 =head2 FindDuplicate
  79
  80 ($biblionumber,$biblionumber,$title) = FindDuplicate($record);
  81
  82 This function attempts to find duplicate records using a hard-coded, fairly simplistic algorithm
  83
  84 =cut
  85
  86 sub FindDuplicate {
  87     my ($record) = @_;
  88     my $dbh = C4::Context->dbh;
  89     my $result = TransformMarcToKoha( $dbh, $record, '' );
  90     my $sth;
  91     my $query;
  92     my $search;
  93     my $type;
  94     my ( $biblionumber, $title );
  95
  96     # search duplicate on ISBN, easy and fast..
  97     # ... normalize first
  98     if ( $result->{isbn} ) {
  99         $result->{isbn} =~ s/\(.*$//;
 100         $result->{isbn} =~ s/\s+$//;
 101         $query = "isbn:$result->{isbn}";
 102     }
 103     else {
 104         my $QParser;
 105         $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser'));
 106         my $titleindex;
 107         my $authorindex;
 108         my $op;
 109
 110         if ($QParser) {
 111             $titleindex = 'title|exact';
 112             $authorindex = 'author|exact';
 113             $op = '&&';
 114             $QParser->custom_data->{'QueryAutoTruncate'} = C4::Context->preference('QueryAutoTruncate');
 115         } else {
 116             $titleindex = 'ti,ext';
 117             $authorindex = 'au,ext';
 118             $op = 'and';
 119         }
 120
 121         $result->{title} =~ s /\\//g;
 122         $result->{title} =~ s /\"//g;
 123         $result->{title} =~ s /\(//g;
 124         $result->{title} =~ s /\)//g;
 125
 126         # FIXME: instead of removing operators, could just do
 127         # quotes around the value
 128         $result->{title} =~ s/(and|or|not)//g;
 129         $query = "$titleindex:\"$result->{title}\"";
 130         if   ( $result->{author} ) {
 131             $result->{author} =~ s /\\//g;
 132             $result->{author} =~ s /\"//g;
 133             $result->{author} =~ s /\(//g;
 134             $result->{author} =~ s /\)//g;
 135
 136             # remove valid operators
 137             $result->{author} =~ s/(and|or|not)//g;
 138             $query .= " $op $authorindex:\"$result->{author}\"";
 139         }
 140     }
 141
 142     my ( $error, $searchresults, undef ) = SimpleSearch($query); # FIXME :: hardcoded !
 143     my @results;
 144     if (!defined $error) {
 145         foreach my $possible_duplicate_record (@{$searchresults}) {
 146             my $marcrecord = new_record_from_zebra(
 147                 'biblioserver',
 148                 $possible_duplicate_record
 149             );
 150
 151             my $result = TransformMarcToKoha( $dbh, $marcrecord, '' );
 152
 153             # FIXME :: why 2 $biblionumber ?
 154             if ($result) {
 155                 push @results, $result->{'biblionumber'};
 156                 push @results, $result->{'title'};
 157             }
 158         }
 159     }
 160     return @results;
 161 }
 162
 163 =head2 SimpleSearch
 164
 165 ( $error, $results, $total_hits ) = SimpleSearch( $query, $offset, $max_results, [@servers] );
 166
 167 This function provides a simple search API on the bibliographic catalog
 168
 169 =over 2
 170
 171 =item C<input arg:>
 172
 173     * $query can be a simple keyword or a complete CCL query
 174     * @servers is optional. Defaults to biblioserver as found in koha-conf.xml
 175     * $offset - If present, represents the number of records at the beggining to omit. Defaults to 0
 176     * $max_results - if present, determines the maximum number of records to fetch. undef is All. defaults to undef.
 177
 178
 179 =item C<Return:>
 180
 181     Returns an array consisting of three elements
 182     * $error is undefined unless an error is detected
 183     * $results is a reference to an array of records.
 184     * $total_hits is the number of hits that would have been returned with no limit
 185
 186     If an error is returned the two other return elements are undefined. If error itself is undefined
 187     the other two elements are always defined
 188
 189 =item C<usage in the script:>
 190
 191 =back
 192
 193 my ( $error, $marcresults, $total_hits ) = SimpleSearch($query);
 194
 195 if (defined $error) {
 196     $template->param(query_error => $error);
 197     warn "error: ".$error;
 198     output_html_with_http_headers $input, $cookie, $template->output;
 199     exit;
 200 }
 201
 202 my $hits = @{$marcresults};
 203 my @results;
 204
 205 for my $r ( @{$marcresults} ) {
 206     my $marcrecord = MARC::File::USMARC::decode($r);
 207     my $biblio = TransformMarcToKoha(C4::Context->dbh,$marcrecord,q{});
 208
 209     #build the iarray of hashs for the template.
 210     push @results, {
 211         title           => $biblio->{'title'},
 212         subtitle        => $biblio->{'subtitle'},
 213         biblionumber    => $biblio->{'biblionumber'},
 214         author          => $biblio->{'author'},
 215         publishercode   => $biblio->{'publishercode'},
 216         publicationyear => $biblio->{'publicationyear'},
 217         };
 218
 219 }
 220
 221 $template->param(result=>\@results);
 222
 223 =cut
 224
 225 sub SimpleSearch {
 226     my ( $query, $offset, $max_results, $servers )  = @_;
 227
 228     return ( 'No query entered', undef, undef ) unless $query;
 229     # FIXME hardcoded value. See catalog/search.pl & opac-search.pl too.
 230     my @servers = defined ( $servers ) ? @$servers : ( 'biblioserver' );
 231     my @zoom_queries;
 232     my @tmpresults;
 233     my @zconns;
 234     my $results = [];
 235     my $total_hits = 0;
 236
 237     my $QParser;
 238     $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser') && ! ($query =~ m/\w,\w|\w=\w/));
 239     if ($QParser) {
 240         $QParser->custom_data->{'QueryAutoTruncate'} = C4::Context->preference('QueryAutoTruncate');
 241     }
 242
 243     # Initialize & Search Zebra
 244     for ( my $i = 0 ; $i < @servers ; $i++ ) {
 245         eval {
 246             $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
 247             if ($QParser) {
 248                 $query =~ s/=/:/g;
 249                 $QParser->parse( $query );
 250                 $query = $QParser->target_syntax($servers[$i]);
 251                 $zoom_queries[$i] = new ZOOM::Query::PQF( $query, $zconns[$i]);
 252             } else {
 253                 $query =~ s/:/=/g;
 254                 $zoom_queries[$i] = new ZOOM::Query::CCL2RPN( $query, $zconns[$i]);
 255             }
 256             $tmpresults[$i] = $zconns[$i]->search( $zoom_queries[$i] );
 257
 258             # error handling
 259             my $error =
 260                 $zconns[$i]->errmsg() . " ("
 261               . $zconns[$i]->errcode() . ") "
 262               . $zconns[$i]->addinfo() . " "
 263               . $zconns[$i]->diagset();
 264
 265             return ( $error, undef, undef ) if $zconns[$i]->errcode();
 266         };
 267         if ($@) {
 268
 269             # caught a ZOOM::Exception
 270             my $error =
 271                 $@->message() . " ("
 272               . $@->code() . ") "
 273               . $@->addinfo() . " "
 274               . $@->diagset();
 275             warn $error." for query: $query";
 276             return ( $error, undef, undef );
 277         }
 278     }
 279
 280     _ZOOM_event_loop(
 281         \@zconns,
 282         \@tmpresults,
 283         sub {
 284             my ($i, $size) = @_;
 285             my $first_record = defined($offset) ? $offset + 1 : 1;
 286             my $hits = $tmpresults[ $i - 1 ]->size();
 287             $total_hits += $hits;
 288             my $last_record = $hits;
 289             if ( defined $max_results && $offset + $max_results < $hits ) {
 290                 $last_record = $offset + $max_results;
 291             }
 292
 293             for my $j ( $first_record .. $last_record ) {
 294                 my $record = eval {
 295                   $tmpresults[ $i - 1 ]->record( $j - 1 )->raw()
 296                   ;    # 0 indexed
 297                 };
 298                 push @{$results}, $record if defined $record;
 299             }
 300         }
 301     );
 302
 303     foreach my $zoom_query (@zoom_queries) {
 304         $zoom_query->destroy();
 305     }
 306
 307     return ( undef, $results, $total_hits );
 308 }
 309
 310 =head2 getRecords
 311
 312 ( undef, $results_hashref, \@facets_loop ) = getRecords (
 313
 314         $koha_query,       $simple_query, $sort_by_ref,    $servers_ref,
 315         $results_per_page, $offset,       $expanded_facet, $branches,$itemtypes,
 316         $query_type,       $scan
 317     );
 318
 319 The all singing, all dancing, multi-server, asynchronous, scanning,
 320 searching, record nabbing, facet-building
 321
 322 See verbse embedded documentation.
 323
 324 =cut
 325
 326 sub getRecords {
 327     my (
 328         $koha_query,       $simple_query, $sort_by_ref,    $servers_ref,
 329         $results_per_page, $offset,       $expanded_facet, $branches,
 330         $itemtypes,        $query_type,   $scan,           $opac
 331     ) = @_;
 332
 333     my @servers = @$servers_ref;
 334     my @sort_by = @$sort_by_ref;
 335
 336     # Initialize variables for the ZOOM connection and results object
 337     my $zconn;
 338     my @zconns;
 339     my @results;
 340     my $results_hashref = ();
 341
 342     # Initialize variables for the faceted results objects
 343     my $facets_counter = ();
 344     my $facets_info    = ();
 345     my $facets         = getFacets();
 346     my $facets_maxrecs = C4::Context->preference('maxRecordsForFacets')||20;
 347
 348     my @facets_loop;    # stores the ref to array of hashes for template facets loop
 349
 350     ### LOOP THROUGH THE SERVERS
 351     for ( my $i = 0 ; $i < @servers ; $i++ ) {
 352         $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
 353
 354 # perform the search, create the results objects
 355 # if this is a local search, use the $koha-query, if it's a federated one, use the federated-query
 356         my $query_to_use = ($servers[$i] =~ /biblioserver/) ? $koha_query : $simple_query;
 357
 358         #$query_to_use = $simple_query if $scan;
 359         warn $simple_query if ( $scan and $DEBUG );
 360
 361         # Check if we've got a query_type defined, if so, use it
 362         eval {
 363             if ($query_type) {
 364                 if ($query_type =~ /^ccl/) {
 365                     $query_to_use =~ s/\:/\=/g;    # change : to = last minute (FIXME)
 366                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::CCL2RPN($query_to_use, $zconns[$i]));
 367                 } elsif ($query_type =~ /^cql/) {
 368                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::CQL($query_to_use, $zconns[$i]));
 369                 } elsif ($query_type =~ /^pqf/) {
 370                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::PQF($query_to_use, $zconns[$i]));
 371                 } else {
 372                     warn "Unknown query_type '$query_type'.  Results undetermined.";
 373                 }
 374             } elsif ($scan) {
 375                     $results[$i] = $zconns[$i]->scan(  new ZOOM::Query::CCL2RPN($query_to_use, $zconns[$i]));
 376             } else {
 377                     $results[$i] = $zconns[$i]->search(new ZOOM::Query::CCL2RPN($query_to_use, $zconns[$i]));
 378             }
 379         };
 380         if ($@) {
 381             warn "WARNING: query problem with $query_to_use " . $@;
 382         }
 383
 384         # Concatenate the sort_by limits and pass them to the results object
 385         # Note: sort will override rank
 386         my $sort_by;
 387         foreach my $sort (@sort_by) {
 388             if ( $sort eq "author_az" || $sort eq "author_asc" ) {
 389                 $sort_by .= "1=1003 <i ";
 390             }
 391             elsif ( $sort eq "author_za" || $sort eq "author_dsc" ) {
 392                 $sort_by .= "1=1003 >i ";
 393             }
 394             elsif ( $sort eq "popularity_asc" ) {
 395                 $sort_by .= "1=9003 <i ";
 396             }
 397             elsif ( $sort eq "popularity_dsc" ) {
 398                 $sort_by .= "1=9003 >i ";
 399             }
 400             elsif ( $sort eq "call_number_asc" ) {
 401                 $sort_by .= "1=8007  <i ";
 402             }
 403             elsif ( $sort eq "call_number_dsc" ) {
 404                 $sort_by .= "1=8007 >i ";
 405             }
 406             elsif ( $sort eq "pubdate_asc" ) {
 407                 $sort_by .= "1=31 <i ";
 408             }
 409             elsif ( $sort eq "pubdate_dsc" ) {
 410                 $sort_by .= "1=31 >i ";
 411             }
 412             elsif ( $sort eq "acqdate_asc" ) {
 413                 $sort_by .= "1=32 <i ";
 414             }
 415             elsif ( $sort eq "acqdate_dsc" ) {
 416                 $sort_by .= "1=32 >i ";
 417             }
 418             elsif ( $sort eq "title_az" || $sort eq "title_asc" ) {
 419                 $sort_by .= "1=4 <i ";
 420             }
 421             elsif ( $sort eq "title_za" || $sort eq "title_dsc" ) {
 422                 $sort_by .= "1=4 >i ";
 423             }
 424             else {
 425                 warn "Ignoring unrecognized sort '$sort' requested" if $sort_by;
 426             }
 427         }
 428         if ( $sort_by && !$scan && $results[$i] ) {
 429             if ( $results[$i]->sort( "yaz", $sort_by ) < 0 ) {
 430                 warn "WARNING sort $sort_by failed";
 431             }
 432         }
 433     }    # finished looping through servers
 434
 435     # The big moment: asynchronously retrieve results from all servers
 436         _ZOOM_event_loop(
 437             \@zconns,
 438             \@results,
 439             sub {
 440                 my ( $i, $size ) = @_;
 441                 my $results_hash;
 442
 443                 # loop through the results
 444                 $results_hash->{'hits'} = $size;
 445                 my $times;
 446                 if ( $offset + $results_per_page <= $size ) {
 447                     $times = $offset + $results_per_page;
 448                 }
 449                 else {
 450                     $times = $size;
 451                 }
 452
 453                 for ( my $j = $offset ; $j < $times ; $j++ ) {
 454                     my $records_hash;
 455                     my $record;
 456
 457                     ## Check if it's an index scan
 458                     if ($scan) {
 459                         my ( $term, $occ ) = $results[ $i - 1 ]->display_term($j);
 460
 461                  # here we create a minimal MARC record and hand it off to the
 462                  # template just like a normal result ... perhaps not ideal, but
 463                  # it works for now
 464                         my $tmprecord = MARC::Record->new();
 465                         $tmprecord->encoding('UTF-8');
 466                         my $tmptitle;
 467                         my $tmpauthor;
 468
 469                 # the minimal record in author/title (depending on MARC flavour)
 470                         if ( C4::Context->preference("marcflavour") eq
 471                             "UNIMARC" )
 472                         {
 473                             $tmptitle = MARC::Field->new(
 474                                 '200', ' ', ' ',
 475                                 a => $term,
 476                                 f => $occ
 477                             );
 478                             $tmprecord->append_fields($tmptitle);
 479                         }
 480                         else {
 481                             $tmptitle =
 482                               MARC::Field->new( '245', ' ', ' ', a => $term, );
 483                             $tmpauthor =
 484                               MARC::Field->new( '100', ' ', ' ', a => $occ, );
 485                             $tmprecord->append_fields($tmptitle);
 486                             $tmprecord->append_fields($tmpauthor);
 487                         }
 488                         $results_hash->{'RECORDS'}[$j] =
 489                           $tmprecord->as_usmarc();
 490                     }
 491
 492                     # not an index scan
 493                     else {
 494                         $record = $results[ $i - 1 ]->record($j)->raw();
 495                         # warn "RECORD $j:".$record;
 496                         $results_hash->{'RECORDS'}[$j] = $record;
 497                     }
 498
 499                 }
 500                 $results_hashref->{ $servers[ $i - 1 ] } = $results_hash;
 501
 502 # Fill the facets while we're looping, but only for the biblioserver and not for a scan
 503                 if ( !$scan && $servers[ $i - 1 ] =~ /biblioserver/ ) {
 504
 505                     my $jmax =
 506                       $size > $facets_maxrecs ? $facets_maxrecs : $size;
 507                     for my $facet (@$facets) {
 508                         for ( my $j = 0 ; $j < $jmax ; $j++ ) {
 509
 510                             my $marc_record = new_record_from_zebra (
 511                                     'biblioserver',
 512                                     $results[ $i - 1 ]->record($j)->raw()
 513                             );
 514
 515                             if ( ! defined $marc_record ) {
 516                                 warn "ERROR DECODING RECORD - $@: " .
 517                                     $results[ $i - 1 ]->record($j)->raw();
 518                                 next;
 519                             }
 520
 521                             my @used_datas = ();
 522
 523                             foreach my $tag ( @{ $facet->{tags} } ) {
 524
 525                                 # avoid first line
 526                                 my $tag_num = substr( $tag, 0, 3 );
 527                                 my $subfield_letters = substr( $tag, 3 );
 528                                 # Removed when as_string fixed
 529                                 my @subfields = $subfield_letters =~ /./sg;
 530
 531                                 my @fields = $marc_record->field($tag_num);
 532                                 foreach my $field (@fields) {
 533                                     my $data = $field->as_string( $subfield_letters, $facet->{sep} );
 534
 535                                     unless ( grep { /^$data$/ } @used_datas ) {
 536                                         push @used_datas, $data;
 537                                         $facets_counter->{ $facet->{idx} }->{$data}++;
 538                                     }
 539                                 } # fields
 540                             }    # field codes
 541                         }    # records
 542                         $facets_info->{ $facet->{idx} }->{label_value} =
 543                           $facet->{label};
 544                         $facets_info->{ $facet->{idx} }->{expanded} =
 545                           $facet->{expanded};
 546                     }    # facets
 547                 }
 548
 549                 # warn "connection ", $i-1, ": $size hits";
 550                 # warn $results[$i-1]->record(0)->render() if $size > 0;
 551
 552                 # BUILD FACETS
 553                 if ( $servers[ $i - 1 ] =~ /biblioserver/ ) {
 554                     for my $link_value (
 555                         sort { $facets_counter->{$b} <=> $facets_counter->{$a} }
 556                         keys %$facets_counter
 557                       )
 558                     {
 559                         my $expandable;
 560                         my $number_of_facets;
 561                         my @this_facets_array;
 562                         for my $one_facet (
 563                             sort {
 564                                 $facets_counter->{$link_value}
 565                                   ->{$b} <=> $facets_counter->{$link_value}
 566                                   ->{$a}
 567                             } keys %{ $facets_counter->{$link_value} }
 568                           )
 569                         {
 570                             $number_of_facets++;
 571                             if (   ( $number_of_facets <= 5 )
 572                                 || ( $expanded_facet eq $link_value )
 573                                 || ( $facets_info->{$link_value}->{'expanded'} )
 574                               )
 575                             {
 576
 577 # Sanitize the link value : parenthesis, question and exclamation mark will cause errors with CCL
 578                                 my $facet_link_value = $one_facet;
 579                                 $facet_link_value =~ s/[()!?¡¿؟]/ /g;
 580
 581                                 # fix the length that will display in the label,
 582                                 my $facet_label_value = $one_facet;
 583                                 my $facet_max_length  = C4::Context->preference(
 584                                     'FacetLabelTruncationLength')
 585                                   || 20;
 586                                 $facet_label_value =
 587                                   substr( $one_facet, 0, $facet_max_length )
 588                                   . "..."
 589                                   if length($facet_label_value) >
 590                                       $facet_max_length;
 591
 592                             # if it's a branch, label by the name, not the code,
 593                                 if ( $link_value =~ /branch/ ) {
 594                                     if (   defined $branches
 595                                         && ref($branches) eq "HASH"
 596                                         && defined $branches->{$one_facet}
 597                                         && ref( $branches->{$one_facet} ) eq
 598                                         "HASH" )
 599                                     {
 600                                         $facet_label_value =
 601                                           $branches->{$one_facet}
 602                                           ->{'branchname'};
 603                                     }
 604                                     else {
 605                                         $facet_label_value = "*";
 606                                     }
 607                                 }
 608
 609                           # if it's a itemtype, label by the name, not the code,
 610                                 if ( $link_value =~ /itype/ ) {
 611                                     if (   defined $itemtypes
 612                                         && ref($itemtypes) eq "HASH"
 613                                         && defined $itemtypes->{$one_facet}
 614                                         && ref( $itemtypes->{$one_facet} ) eq
 615                                         "HASH" )
 616                                     {
 617                                         $facet_label_value =
 618                                           $itemtypes->{$one_facet}
 619                                           ->{'description'};
 620                                     }
 621                                 }
 622
 623                # also, if it's a location code, use the name instead of the code
 624                                 if ( $link_value =~ /location/ ) {
 625                                     $facet_label_value =
 626                                       GetKohaAuthorisedValueLib( 'LOC',
 627                                         $one_facet, $opac );
 628                                 }
 629
 630                 # but we're down with the whole label being in the link's title.
 631                                 push @this_facets_array,
 632                                   {
 633                                     facet_count =>
 634                                       $facets_counter->{$link_value}
 635                                       ->{$one_facet},
 636                                     facet_label_value => $facet_label_value,
 637                                     facet_title_value => $one_facet,
 638                                     facet_link_value  => $facet_link_value,
 639                                     type_link_value   => $link_value,
 640                                   }
 641                                   if ($facet_label_value);
 642                             }
 643                         }
 644
 645                         # handle expanded option
 646                         unless ( $facets_info->{$link_value}->{'expanded'} ) {
 647                             $expandable = 1
 648                               if ( ( $number_of_facets > 5 )
 649                                 && ( $expanded_facet ne $link_value ) );
 650                         }
 651                         push @facets_loop,
 652                           {
 653                             type_link_value => $link_value,
 654                             type_id         => $link_value . "_id",
 655                             "type_label_"
 656                               . $facets_info->{$link_value}->{'label_value'} =>
 657                               1,
 658                             facets     => \@this_facets_array,
 659                             expandable => $expandable,
 660                             expand     => $link_value,
 661                           }
 662                           unless (
 663                             (
 664                                 $facets_info->{$link_value}->{'label_value'} =~
 665                                 /Libraries/
 666                             )
 667                             and ( C4::Context->preference('singleBranchMode') )
 668                           );
 669                     }
 670                 }
 671             }
 672         );
 673     return ( undef, $results_hashref, \@facets_loop );
 674 }
 675
 676 sub pazGetRecords {
 677     my (
 678         $koha_query,       $simple_query, $sort_by_ref,    $servers_ref,
 679         $results_per_page, $offset,       $expanded_facet, $branches,
 680         $query_type,       $scan
 681     ) = @_;
 682
 683     my $paz = C4::Search::PazPar2->new(C4::Context->config('pazpar2url'));
 684     $paz->init();
 685     $paz->search($simple_query);
 686     sleep 1;   # FIXME: WHY?
 687
 688     # do results
 689     my $results_hashref = {};
 690     my $stats = XMLin($paz->stat);
 691     my $results = XMLin($paz->show($offset, $results_per_page, 'work-title:1'), forcearray => 1);
 692
 693     # for a grouped search result, the number of hits
 694     # is the number of groups returned; 'bib_hits' will have
 695     # the total number of bibs.
 696     $results_hashref->{'biblioserver'}->{'hits'} = $results->{'merged'}->[0];
 697     $results_hashref->{'biblioserver'}->{'bib_hits'} = $stats->{'hits'};
 698
 699     HIT: foreach my $hit (@{ $results->{'hit'} }) {
 700         my $recid = $hit->{recid}->[0];
 701
 702         my $work_title = $hit->{'md-work-title'}->[0];
 703         my $work_author;
 704         if (exists $hit->{'md-work-author'}) {
 705             $work_author = $hit->{'md-work-author'}->[0];
 706         }
 707         my $group_label = (defined $work_author) ? "$work_title / $work_author" : $work_title;
 708
 709         my $result_group = {};
 710         $result_group->{'group_label'} = $group_label;
 711         $result_group->{'group_merge_key'} = $recid;
 712
 713         my $count = 1;
 714         if (exists $hit->{count}) {
 715             $count = $hit->{count}->[0];
 716         }
 717         $result_group->{'group_count'} = $count;
 718
 719         for (my $i = 0; $i < $count; $i++) {
 720             # FIXME -- may need to worry about diacritics here
 721             my $rec = $paz->record($recid, $i);
 722             push @{ $result_group->{'RECORDS'} }, $rec;
 723         }
 724
 725         push @{ $results_hashref->{'biblioserver'}->{'GROUPS'} }, $result_group;
 726     }
 727
 728     # pass through facets
 729     my $termlist_xml = $paz->termlist('author,subject');
 730     my $terms = XMLin($termlist_xml, forcearray => 1);
 731     my @facets_loop = ();
 732     #die Dumper($results);
 733 #    foreach my $list (sort keys %{ $terms->{'list'} }) {
 734 #        my @facets = ();
 735 #        foreach my $facet (sort @{ $terms->{'list'}->{$list}->{'term'} } ) {
 736 #            push @facets, {
 737 #                facet_label_value => $facet->{'name'}->[0],
 738 #            };
 739 #        }
 740 #        push @facets_loop, ( {
 741 #            type_label => $list,
 742 #            facets => \@facets,
 743 #        } );
 744 #    }
 745
 746     return ( undef, $results_hashref, \@facets_loop );
 747 }
 748
 749 # STOPWORDS
 750 sub _remove_stopwords {
 751     my ( $operand, $index ) = @_;
 752     my @stopwords_removed;
 753
 754     # phrase and exact-qualified indexes shouldn't have stopwords removed
 755     if ( $index !~ m/,(phr|ext)/ ) {
 756
 757 # remove stopwords from operand : parse all stopwords & remove them (case insensitive)
 758 #       we use IsAlpha unicode definition, to deal correctly with diacritics.
 759 #       otherwise, a French word like "leçon" woudl be split into "le" "çon", "le"
 760 #       is a stopword, we'd get "çon" and wouldn't find anything...
 761 #
 762                 foreach ( keys %{ C4::Context->stopwords } ) {
 763                         next if ( $_ =~ /(and|or|not)/ );    # don't remove operators
 764                         if ( my ($matched) = ($operand =~
 765                                 /([^\X\p{isAlnum}]\Q$_\E[^\X\p{isAlnum}]|[^\X\p{isAlnum}]\Q$_\E$|^\Q$_\E[^\X\p{isAlnum}])/gi))
 766                         {
 767                                 $operand =~ s/\Q$matched\E/ /gi;
 768                                 push @stopwords_removed, $_;
 769                         }
 770                 }
 771         }
 772     return ( $operand, \@stopwords_removed );
 773 }
 774
 775 # TRUNCATION
 776 sub _detect_truncation {
 777     my ( $operand, $index ) = @_;
 778     my ( @nontruncated, @righttruncated, @lefttruncated, @rightlefttruncated,
 779         @regexpr );
 780     $operand =~ s/^ //g;
 781     my @wordlist = split( /\s/, $operand );
 782     foreach my $word (@wordlist) {
 783         if ( $word =~ s/^\*([^\*]+)\*$/$1/ ) {
 784             push @rightlefttruncated, $word;
 785         }
 786         elsif ( $word =~ s/^\*([^\*]+)$/$1/ ) {
 787             push @lefttruncated, $word;
 788         }
 789         elsif ( $word =~ s/^([^\*]+)\*$/$1/ ) {
 790             push @righttruncated, $word;
 791         }
 792         elsif ( index( $word, "*" ) < 0 ) {
 793             push @nontruncated, $word;
 794         }
 795         else {
 796             push @regexpr, $word;
 797         }
 798     }
 799     return (
 800         \@nontruncated,       \@righttruncated, \@lefttruncated,
 801         \@rightlefttruncated, \@regexpr
 802     );
 803 }
 804
 805 # STEMMING
 806 sub _build_stemmed_operand {
 807     my ($operand,$lang) = @_;
 808     require Lingua::Stem::Snowball ;
 809     my $stemmed_operand=q{};
 810
 811     # If operand contains a digit, it is almost certainly an identifier, and should
 812     # not be stemmed.  This is particularly relevant for ISBNs and ISSNs, which
 813     # can contain the letter "X" - for example, _build_stemmend_operand would reduce
 814     # "014100018X" to "x ", which for a MARC21 database would bring up irrelevant
 815     # results (e.g., "23 x 29 cm." from the 300$c).  Bug 2098.
 816     return $operand if $operand =~ /\d/;
 817
 818 # FIXME: the locale should be set based on the user's language and/or search choice
 819     #warn "$lang";
 820     # Make sure we only use the first two letters from the language code
 821     $lang = lc(substr($lang, 0, 2));
 822     # The language codes for the two variants of Norwegian will now be "nb" and "nn",
 823     # none of which Lingua::Stem::Snowball can use, so we need to "translate" them
 824     if ($lang eq 'nb' || $lang eq 'nn') {
 825       $lang = 'no';
 826     }
 827     my $stemmer = Lingua::Stem::Snowball->new( lang => $lang,
 828                                                encoding => "UTF-8" );
 829
 830     my @words = split( / /, $operand );
 831     my @stems = $stemmer->stem(\@words);
 832     for my $stem (@stems) {
 833         $stemmed_operand .= "$stem";
 834         $stemmed_operand .= "?"
 835           unless ( $stem =~ /(and$|or$|not$)/ ) || ( length($stem) < 3 );
 836         $stemmed_operand .= " ";
 837     }
 838     warn "STEMMED OPERAND: $stemmed_operand" if $DEBUG;
 839     return $stemmed_operand;
 840 }
 841
 842 # FIELD WEIGHTING
 843 sub _build_weighted_query {
 844
 845 # FIELD WEIGHTING - This is largely experimental stuff. What I'm committing works
 846 # pretty well but could work much better if we had a smarter query parser
 847     my ( $operand, $stemmed_operand, $index ) = @_;
 848     my $stemming      = C4::Context->preference("QueryStemming")     || 0;
 849     my $weight_fields = C4::Context->preference("QueryWeightFields") || 0;
 850     my $fuzzy_enabled = C4::Context->preference("QueryFuzzy")        || 0;
 851     $operand =~ s/"/ /g;    # Bug 7518: searches with quotation marks don't work
 852
 853     my $weighted_query .= "(rk=(";    # Specifies that we're applying rank
 854
 855     # Keyword, or, no index specified
 856     if ( ( $index eq 'kw' ) || ( !$index ) ) {
 857         $weighted_query .=
 858           "Title-cover,ext,r1=\"$operand\"";    # exact title-cover
 859         $weighted_query .= " or ti,ext,r2=\"$operand\"";    # exact title
 860         $weighted_query .= " or Title-cover,phr,r3=\"$operand\"";    # phrase title
 861         $weighted_query .= " or ti,wrdl,r4=\"$operand\"";    # words in title
 862           #$weighted_query .= " or any,ext,r4=$operand";               # exact any
 863           #$weighted_query .=" or kw,wrdl,r5=\"$operand\"";            # word list any
 864         $weighted_query .= " or wrdl,fuzzy,r8=\"$operand\""
 865           if $fuzzy_enabled;    # add fuzzy, word list
 866         $weighted_query .= " or wrdl,right-Truncation,r9=\"$stemmed_operand\""
 867           if ( $stemming and $stemmed_operand )
 868           ;                     # add stemming, right truncation
 869         $weighted_query .= " or wrdl,r9=\"$operand\"";
 870
 871         # embedded sorting: 0 a-z; 1 z-a
 872         # $weighted_query .= ") or (sort1,aut=1";
 873     }
 874
 875     # Barcode searches should skip this process
 876     elsif ( $index eq 'bc' ) {
 877         $weighted_query .= "bc=\"$operand\"";
 878     }
 879
 880     # Authority-number searches should skip this process
 881     elsif ( $index eq 'an' ) {
 882         $weighted_query .= "an=\"$operand\"";
 883     }
 884
 885     # If the index already has more than one qualifier, wrap the operand
 886     # in quotes and pass it back (assumption is that the user knows what they
 887     # are doing and won't appreciate us mucking up their query
 888     elsif ( $index =~ ',' ) {
 889         $weighted_query .= " $index=\"$operand\"";
 890     }
 891
 892     #TODO: build better cases based on specific search indexes
 893     else {
 894         $weighted_query .= " $index,ext,r1=\"$operand\"";    # exact index
 895           #$weighted_query .= " or (title-sort-az=0 or $index,startswithnt,st-word,r3=$operand #)";
 896         $weighted_query .= " or $index,phr,r3=\"$operand\"";    # phrase index
 897         $weighted_query .= " or $index,wrdl,r6=\"$operand\"";    # word list index
 898         $weighted_query .= " or $index,wrdl,fuzzy,r8=\"$operand\""
 899           if $fuzzy_enabled;    # add fuzzy, word list
 900         $weighted_query .= " or $index,wrdl,rt,r9=\"$stemmed_operand\""
 901           if ( $stemming and $stemmed_operand );    # add stemming, right truncation
 902     }
 903
 904     $weighted_query .= "))";                       # close rank specification
 905     return $weighted_query;
 906 }
 907
 908 =head2 getIndexes
 909
 910 Return an array with available indexes.
 911
 912 =cut
 913
 914 sub getIndexes{
 915     my @indexes = (
 916                     # biblio indexes
 917                     'ab',
 918                     'Abstract',
 919                     'acqdate',
 920                     'allrecords',
 921                     'an',
 922                     'Any',
 923                     'at',
 924                     'au',
 925                     'aub',
 926                     'aud',
 927                     'audience',
 928                     'auo',
 929                     'aut',
 930                     'Author',
 931                     'Author-in-order ',
 932                     'Author-personal-bibliography',
 933                     'Authority-Number',
 934                     'authtype',
 935                     'bc',
 936                     'Bib-level',
 937                     'biblionumber',
 938                     'bio',
 939                     'biography',
 940                     'callnum',
 941                     'cfn',
 942                     'Chronological-subdivision',
 943                     'cn-bib-source',
 944                     'cn-bib-sort',
 945                     'cn-class',
 946                     'cn-item',
 947                     'cn-prefix',
 948                     'cn-suffix',
 949                     'cpn',
 950                     'Code-institution',
 951                     'Conference-name',
 952                     'Conference-name-heading',
 953                     'Conference-name-see',
 954                     'Conference-name-seealso',
 955                     'Content-type',
 956                     'Control-number',
 957                     'copydate',
 958                     'Corporate-name',
 959                     'Corporate-name-heading',
 960                     'Corporate-name-see',
 961                     'Corporate-name-seealso',
 962                     'Country-publication',
 963                     'ctype',
 964                     'curriculum',
 965                     'date-entered-on-file',
 966                     'Date-of-acquisition',
 967                     'Date-of-publication',
 968                     'Dewey-classification',
 969                     'Dissertation-information',
 970                     'EAN',
 971                     'extent',
 972                     'fic',
 973                     'fiction',
 974                     'Form-subdivision',
 975                     'format',
 976                     'Geographic-subdivision',
 977                     'he',
 978                     'Heading',
 979                     'Heading-use-main-or-added-entry',
 980                     'Heading-use-series-added-entry ',
 981                     'Heading-use-subject-added-entry',
 982                     'Host-item',
 983                     'id-other',
 984                     'Illustration-code',
 985                     'Index-term-genre',
 986                     'Index-term-uncontrolled',
 987                     'ISBN',
 988                     'isbn',
 989                     'ISSN',
 990                     'issn',
 991                     'itemtype',
 992                     'kw',
 993                     'Koha-Auth-Number',
 994                     'l-format',
 995                     'language',
 996                     'language-original',
 997                     'lc-card',
 998                     'LC-card-number',
 999                     'lcn',
1000                     'lex',
1001                     'llength',
1002                     'ln',
1003                     'ln-audio',
1004                     'ln-subtitle',
1005                     'Local-classification',
1006                     'Local-number',
1007                     'Match-heading',
1008                     'Match-heading-see-from',
1009                     'Material-type',
1010                     'mc-itemtype',
1011                     'mc-rtype',
1012                     'mus',
1013                     'name',
1014                     'Music-number',
1015                     'Name-geographic',
1016                     'Name-geographic-heading',
1017                     'Name-geographic-see',
1018                     'Name-geographic-seealso',
1019                     'nb',
1020                     'Note',
1021                     'notes',
1022                     'ns',
1023                     'nt',
1024                     'pb',
1025                     'Personal-name',
1026                     'Personal-name-heading',
1027                     'Personal-name-see',
1028                     'Personal-name-seealso',
1029                     'pl',
1030                     'Place-publication',
1031                     'pn',
1032                     'popularity',
1033                     'pubdate',
1034                     'Publisher',
1035                     'Record-control-number',
1036                     'rcn',
1037                     'Record-type',
1038                     'rtype',
1039                     'se',
1040                     'See',
1041                     'See-also',
1042                     'sn',
1043                     'Stock-number',
1044                     'su',
1045                     'Subject',
1046                     'Subject-heading-thesaurus',
1047                     'Subject-name-personal',
1048                     'Subject-subdivision',
1049                     'Summary',
1050                     'Suppress',
1051                     'su-geo',
1052                     'su-na',
1053                     'su-to',
1054                     'su-ut',
1055                     'ut',
1056                     'Term-genre-form',
1057                     'Term-genre-form-heading',
1058                     'Term-genre-form-see',
1059                     'Term-genre-form-seealso',
1060                     'ti',
1061                     'Title',
1062                     'Title-cover',
1063                     'Title-series',
1064                     'Title-uniform',
1065                     'Title-uniform-heading',
1066                     'Title-uniform-see',
1067                     'Title-uniform-seealso',
1068                     'totalissues',
1069                     'yr',
1070
1071                     # items indexes
1072                     'acqsource',
1073                     'barcode',
1074                     'bc',
1075                     'branch',
1076                     'ccode',
1077                     'classification-source',
1078                     'cn-sort',
1079                     'coded-location-qualifier',
1080                     'copynumber',
1081                     'damaged',
1082                     'datelastborrowed',
1083                     'datelastseen',
1084                     'holdingbranch',
1085                     'homebranch',
1086                     'issues',
1087                     'item',
1088                     'itemnumber',
1089                     'itype',
1090                     'Local-classification',
1091                     'location',
1092                     'lost',
1093                     'materials-specified',
1094                     'mc-ccode',
1095                     'mc-itype',
1096                     'mc-loc',
1097                     'notforloan',
1098                     'Number-local-acquisition',
1099                     'onloan',
1100                     'price',
1101                     'renewals',
1102                     'replacementprice',
1103                     'replacementpricedate',
1104                     'reserves',
1105                     'restricted',
1106                     'stack',
1107                     'stocknumber',
1108                     'inv',
1109                     'uri',
1110                     'withdrawn',
1111
1112                     # subject related
1113                   );
1114
1115     return \@indexes;
1116 }
1117
1118 =head2 _handle_exploding_index
1119
1120     my $query = _handle_exploding_index($index, $term)
1121
1122 Callback routine to generate the search for "exploding" indexes (i.e.
1123 those indexes which are turned into multiple or-connected searches based
1124 on authority data).
1125
1126 =cut
1127
1128 sub _handle_exploding_index {
1129     my ($QParser, $filter, $params, $negate, $server) = @_;
1130     my $index = $filter;
1131     my $term = join(' ', @$params);
1132
1133     return unless ($index =~ m/(su-br|su-na|su-rl)/ && $term);
1134
1135     my $marcflavour = C4::Context->preference('marcflavour');
1136
1137     my $codesubfield = $marcflavour eq 'UNIMARC' ? '5' : 'w';
1138     my $wantedcodes = '';
1139     my @subqueries = ( "\@attr 1=Subject \@attr 4=1 \"$term\"");
1140     my ($error, $results, $total_hits) = SimpleSearch( "he:$term", undef, undef, [ "authorityserver" ] );
1141     foreach my $auth (@$results) {
1142         my $record = MARC::Record->new_from_usmarc($auth);
1143         my @references = $record->field('5..');
1144         if (@references) {
1145             if ($index eq 'su-br') {
1146                 $wantedcodes = 'g';
1147             } elsif ($index eq 'su-na') {
1148                 $wantedcodes = 'h';
1149             } elsif ($index eq 'su-rl') {
1150                 $wantedcodes = '';
1151             }
1152             foreach my $reference (@references) {
1153                 my $codes = $reference->subfield($codesubfield);
1154                 push @subqueries, '@attr 1=Subject @attr 4=1 "' . $reference->as_string('abcdefghijlmnopqrstuvxyz') . '"' if (($codes && $codes eq $wantedcodes) || !$wantedcodes);
1155             }
1156         }
1157     }
1158     my $query = ' @or ' x (scalar(@subqueries) - 1) . join(' ', @subqueries);
1159     return $query;
1160 }
1161
1162 =head2 parseQuery
1163
1164     ( $operators, $operands, $indexes, $limits,
1165       $sort_by, $scan, $lang ) =
1166             buildQuery ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang);
1167
1168 Shim function to ease the transition from buildQuery to a new QueryParser.
1169 This function is called at the beginning of buildQuery, and modifies
1170 buildQuery's input. If it can handle the input, it returns a query that
1171 buildQuery will not try to parse.
1172 =cut
1173
1174 sub parseQuery {
1175     my ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang) = @_;
1176
1177     my @operators = $operators ? @$operators : ();
1178     my @indexes   = $indexes   ? @$indexes   : ();
1179     my @operands  = $operands  ? @$operands  : ();
1180     my @limits    = $limits    ? @$limits    : ();
1181     my @sort_by   = $sort_by   ? @$sort_by   : ();
1182
1183     my $query = $operands[0];
1184     my $index;
1185     my $term;
1186     my $query_desc;
1187
1188     my $QParser;
1189     $QParser = C4::Context->queryparser if (C4::Context->preference('UseQueryParser') || $query =~ s/^qp=//);
1190     undef $QParser if ($query =~ m/^(ccl=|pqf=|cql=)/ || grep (/\w,\w|\w=\w/, @operands, @indexes) );
1191     undef $QParser if (scalar @limits > 0);
1192
1193     if ($QParser)
1194     {
1195         $QParser->custom_data->{'QueryAutoTruncate'} = C4::Context->preference('QueryAutoTruncate');
1196         $query = '';
1197         for ( my $ii = 0 ; $ii <= @operands ; $ii++ ) {
1198             next unless $operands[$ii];
1199             $query .= $operators[ $ii - 1 ] eq 'or' ? ' || ' : ' && '
1200               if ($query);
1201             if ( $operands[$ii] =~ /^[^"]\W*[-|_\w]*:\w.*[^"]$/ ) {
1202                 $query .= $operands[$ii];
1203             }
1204             elsif ( $indexes[$ii] =~ m/su-/ ) {
1205                 $query .= $indexes[$ii] . '(' . $operands[$ii] . ')';
1206             }
1207             else {
1208                 $query .=
1209                   ( $indexes[$ii] ? "$indexes[$ii]:" : '' ) . $operands[$ii];
1210             }
1211         }
1212         foreach my $limit (@limits) {
1213         }
1214         if ( scalar(@sort_by) > 0 ) {
1215             my $modifier_re =
1216               '#(' . join( '|', @{ $QParser->modifiers } ) . ')';
1217             $query =~ s/$modifier_re//g;
1218             foreach my $modifier (@sort_by) {
1219                 $query .= " #$modifier";
1220             }
1221         }
1222
1223         $query_desc = $query;
1224         $query_desc =~ s/\s+/ /g;
1225         if ( C4::Context->preference("QueryWeightFields") ) {
1226         }
1227         $QParser->add_bib1_filter_map( 'su-br' => 'biblioserver' =>
1228               { 'target_syntax_callback' => \&_handle_exploding_index } );
1229         $QParser->add_bib1_filter_map( 'su-na' => 'biblioserver' =>
1230               { 'target_syntax_callback' => \&_handle_exploding_index } );
1231         $QParser->add_bib1_filter_map( 'su-rl' => 'biblioserver' =>
1232               { 'target_syntax_callback' => \&_handle_exploding_index } );
1233         $QParser->parse($query);
1234         $operands[0] = "pqf=" . $QParser->target_syntax('biblioserver');
1235     }
1236     else {
1237         require Koha::QueryParser::Driver::PQF;
1238         my $modifier_re = '#(' . join( '|', @{Koha::QueryParser::Driver::PQF->modifiers}) . ')';
1239         s/$modifier_re//g for @operands;
1240     }
1241
1242     return ( $operators, \@operands, $indexes, $limits, $sort_by, $scan, $lang, $query_desc);
1243 }
1244
1245 =head2 buildQuery
1246
1247 ( $error, $query,
1248 $simple_query, $query_cgi,
1249 $query_desc, $limit,
1250 $limit_cgi, $limit_desc,
1251 $stopwords_removed, $query_type ) = buildQuery ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang);
1252
1253 Build queries and limits in CCL, CGI, Human,
1254 handle truncation, stemming, field weighting, stopwords, fuzziness, etc.
1255
1256 See verbose embedded documentation.
1257
1258
1259 =cut
1260
1261 sub buildQuery {
1262     my ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang) = @_;
1263
1264     warn "---------\nEnter buildQuery\n---------" if $DEBUG;
1265
1266     my $query_desc;
1267     ( $operators, $operands, $indexes, $limits, $sort_by, $scan, $lang, $query_desc) = parseQuery($operators, $operands, $indexes, $limits, $sort_by, $scan, $lang);
1268
1269     # dereference
1270     my @operators = $operators ? @$operators : ();
1271     my @indexes   = $indexes   ? @$indexes   : ();
1272     my @operands  = $operands  ? @$operands  : ();
1273     my @limits    = $limits    ? @$limits    : ();
1274     my @sort_by   = $sort_by   ? @$sort_by   : ();
1275
1276     my $stemming         = C4::Context->preference("QueryStemming")        || 0;
1277     my $auto_truncation  = C4::Context->preference("QueryAutoTruncate")    || 0;
1278     my $weight_fields    = C4::Context->preference("QueryWeightFields")    || 0;
1279     my $fuzzy_enabled    = C4::Context->preference("QueryFuzzy")           || 0;
1280     my $remove_stopwords = C4::Context->preference("QueryRemoveStopwords") || 0;
1281
1282     my $query        = $operands[0];
1283     my $simple_query = $operands[0];
1284
1285     # initialize the variables we're passing back
1286     my $query_cgi;
1287     my $query_type;
1288
1289     my $limit;
1290     my $limit_cgi;
1291     my $limit_desc;
1292
1293     my $stopwords_removed;    # flag to determine if stopwords have been removed
1294
1295     my $cclq       = 0;
1296     my $cclindexes = getIndexes();
1297     if ( $query !~ /\s*(ccl=|pqf=|cql=)/ ) {
1298         while ( !$cclq && $query =~ /(?:^|\W)([\w-]+)(,[\w-]+)*[:=]/g ) {
1299             my $dx = lc($1);
1300             $cclq = grep { lc($_) eq $dx } @$cclindexes;
1301         }
1302         $query = "ccl=$query" if $cclq;
1303     }
1304
1305 # for handling ccl, cql, pqf queries in diagnostic mode, skip the rest of the steps
1306 # DIAGNOSTIC ONLY!!
1307     if ( $query =~ /^ccl=/ ) {
1308         my $q=$';
1309         # This is needed otherwise ccl= and &limit won't work together, and
1310         # this happens when selecting a subject on the opac-detail page
1311         @limits = grep {!/^$/} @limits;
1312         if ( @limits ) {
1313             $q .= ' and '.join(' and ', @limits);
1314         }
1315         return ( undef, $q, $q, "q=ccl=".uri_escape($q), $q, '', '', '', '', 'ccl' );
1316     }
1317     if ( $query =~ /^cql=/ ) {
1318         return ( undef, $', $', "q=cql=".uri_escape($'), $', '', '', '', '', 'cql' );
1319     }
1320     if ( $query =~ /^pqf=/ ) {
1321         if ($query_desc) {
1322             $query_cgi = "q=".uri_escape($query_desc);
1323         } else {
1324             $query_desc = $';
1325             $query_cgi = "q=pqf=".uri_escape($');
1326         }
1327         return ( undef, $', $', $query_cgi, $query_desc, '', '', '', '', 'pqf' );
1328     }
1329
1330     # pass nested queries directly
1331     # FIXME: need better handling of some of these variables in this case
1332     # Nested queries aren't handled well and this implementation is flawed and causes users to be
1333     # unable to search for anything containing () commenting out, will be rewritten for 3.4.0
1334 #    if ( $query =~ /(\(|\))/ ) {
1335 #        return (
1336 #            undef,              $query, $simple_query, $query_cgi,
1337 #            $query,             $limit, $limit_cgi,    $limit_desc,
1338 #            $stopwords_removed, 'ccl'
1339 #        );
1340 #    }
1341
1342 # Form-based queries are non-nested and fixed depth, so we can easily modify the incoming
1343 # query operands and indexes and add stemming, truncation, field weighting, etc.
1344 # Once we do so, we'll end up with a value in $query, just like if we had an
1345 # incoming $query from the user
1346     else {
1347         $query = ""
1348           ; # clear it out so we can populate properly with field-weighted, stemmed, etc. query
1349         my $previous_operand
1350           ;    # a flag used to keep track if there was a previous query
1351                # if there was, we can apply the current operator
1352                # for every operand
1353         for ( my $i = 0 ; $i <= @operands ; $i++ ) {
1354
1355             # COMBINE OPERANDS, INDEXES AND OPERATORS
1356             if ( $operands[$i] ) {
1357                 $operands[$i]=~s/^\s+//;
1358
1359               # A flag to determine whether or not to add the index to the query
1360                 my $indexes_set;
1361
1362 # If the user is sophisticated enough to specify an index, turn off field weighting, stemming, and stopword handling
1363                 if ( $operands[$i] =~ /\w(:|=)/ || $scan ) {
1364                     $weight_fields    = 0;
1365                     $stemming         = 0;
1366                     $remove_stopwords = 0;
1367                 } else {
1368                     $operands[$i] =~ s/\?/{?}/g; # need to escape question marks
1369                 }
1370                 my $operand = $operands[$i];
1371                 my $index   = $indexes[$i];
1372
1373                 # Add index-specific attributes
1374                 # Date of Publication
1375                 if ( $index eq 'yr' ) {
1376                     $index .= ",st-numeric";
1377                     $indexes_set++;
1378                                         $stemming = $auto_truncation = $weight_fields = $fuzzy_enabled = $remove_stopwords = 0;
1379                 }
1380
1381                 # Date of Acquisition
1382                 elsif ( $index eq 'acqdate' ) {
1383                     $index .= ",st-date-normalized";
1384                     $indexes_set++;
1385                                         $stemming = $auto_truncation = $weight_fields = $fuzzy_enabled = $remove_stopwords = 0;
1386                 }
1387                 # ISBN,ISSN,Standard Number, don't need special treatment
1388                 elsif ( $index eq 'nb' || $index eq 'ns' ) {
1389                     (
1390                         $stemming,      $auto_truncation,
1391                         $weight_fields, $fuzzy_enabled,
1392                         $remove_stopwords
1393                     ) = ( 0, 0, 0, 0, 0 );
1394
1395                 }
1396
1397                 if(not $index){
1398                     $index = 'kw';
1399                 }
1400
1401                 # Set default structure attribute (word list)
1402                 my $struct_attr = q{};
1403                 unless ( $indexes_set || !$index || $index =~ /,(st-|phr|ext|wrdl)/ || $index =~ /^(nb|ns)$/ ) {
1404                     $struct_attr = ",wrdl";
1405                 }
1406
1407                 # Some helpful index variants
1408                 my $index_plus       = $index . $struct_attr . ':';
1409                 my $index_plus_comma = $index . $struct_attr . ',';
1410
1411                 # Remove Stopwords
1412                 if ($remove_stopwords) {
1413                     ( $operand, $stopwords_removed ) =
1414                       _remove_stopwords( $operand, $index );
1415                     warn "OPERAND w/out STOPWORDS: >$operand<" if $DEBUG;
1416                     warn "REMOVED STOPWORDS: @$stopwords_removed"
1417                       if ( $stopwords_removed && $DEBUG );
1418                 }
1419
1420                 if ($auto_truncation){
1421                         unless ( $index =~ /,(st-|phr|ext)/ ) {
1422                                                 #FIXME only valid with LTR scripts
1423                                                 $operand=join(" ",map{
1424                                                                                         (index($_,"*")>0?"$_":"$_*")
1425                                                                                          }split (/\s+/,$operand));
1426                                                 warn $operand if $DEBUG;
1427                                         }
1428                                 }
1429
1430                 # Detect Truncation
1431                 my $truncated_operand;
1432                 my( $nontruncated, $righttruncated, $lefttruncated,
1433                     $rightlefttruncated, $regexpr
1434                 ) = _detect_truncation( $operand, $index );
1435                 warn
1436 "TRUNCATION: NON:>@$nontruncated< RIGHT:>@$righttruncated< LEFT:>@$lefttruncated< RIGHTLEFT:>@$rightlefttruncated< REGEX:>@$regexpr<"
1437                   if $DEBUG;
1438
1439                 # Apply Truncation
1440                 if (
1441                     scalar(@$righttruncated) + scalar(@$lefttruncated) +
1442                     scalar(@$rightlefttruncated) > 0 )
1443                 {
1444
1445                # Don't field weight or add the index to the query, we do it here
1446                     $indexes_set = 1;
1447                     undef $weight_fields;
1448                     my $previous_truncation_operand;
1449                     if (scalar @$nontruncated) {
1450                         $truncated_operand .= "$index_plus @$nontruncated ";
1451                         $previous_truncation_operand = 1;
1452                     }
1453                     if (scalar @$righttruncated) {
1454                         $truncated_operand .= "and " if $previous_truncation_operand;
1455                         $truncated_operand .= $index_plus_comma . "rtrn:@$righttruncated ";
1456                         $previous_truncation_operand = 1;
1457                     }
1458                     if (scalar @$lefttruncated) {
1459                         $truncated_operand .= "and " if $previous_truncation_operand;
1460                         $truncated_operand .= $index_plus_comma . "ltrn:@$lefttruncated ";
1461                         $previous_truncation_operand = 1;
1462                     }
1463                     if (scalar @$rightlefttruncated) {
1464                         $truncated_operand .= "and " if $previous_truncation_operand;
1465                         $truncated_operand .= $index_plus_comma . "rltrn:@$rightlefttruncated ";
1466                         $previous_truncation_operand = 1;
1467                     }
1468                 }
1469                 $operand = $truncated_operand if $truncated_operand;
1470                 warn "TRUNCATED OPERAND: >$truncated_operand<" if $DEBUG;
1471
1472                 # Handle Stemming
1473                 my $stemmed_operand;
1474                 $stemmed_operand = _build_stemmed_operand($operand, $lang)
1475                                                                                 if $stemming;
1476
1477                 warn "STEMMED OPERAND: >$stemmed_operand<" if $DEBUG;
1478
1479                 # Handle Field Weighting
1480                 my $weighted_operand;
1481                 if ($weight_fields) {
1482                     $weighted_operand = _build_weighted_query( $operand, $stemmed_operand, $index );
1483                     $operand = $weighted_operand;
1484                     $indexes_set = 1;
1485                 }
1486
1487                 warn "FIELD WEIGHTED OPERAND: >$weighted_operand<" if $DEBUG;
1488
1489                 ($query,$query_cgi,$query_desc,$previous_operand) = _build_initial_query({
1490                     query => $query,
1491                     query_cgi => $query_cgi,
1492                     query_desc => $query_desc,
1493                     operator => ($operators[ $i - 1 ]) ? $operators[ $i - 1 ] : '',
1494                     parsed_operand => $operand,
1495                     original_operand => ($operands[$i]) ? $operands[$i] : '',
1496                     index => $index,
1497                     index_plus => $index_plus,
1498                     indexes_set => $indexes_set,
1499                     previous_operand => $previous_operand,
1500                 });
1501
1502             }    #/if $operands
1503         }    # /for
1504     }
1505     warn "QUERY BEFORE LIMITS: >$query<" if $DEBUG;
1506
1507     # add limits
1508     my %group_OR_limits;
1509     my $availability_limit;
1510     foreach my $this_limit (@limits) {
1511         next unless $this_limit;
1512         if ( $this_limit =~ /available/ ) {
1513 #
1514 ## 'available' is defined as (items.onloan is NULL) and (items.itemlost = 0)
1515 ## In English:
1516 ## all records not indexed in the onloan register (zebra) and all records with a value of lost equal to 0
1517             $availability_limit .=
1518 "( ( allrecords,AlwaysMatches='' not onloan,AlwaysMatches='') and (lost,st-numeric=0) )"; #or ( allrecords,AlwaysMatches='' not lost,AlwaysMatches='')) )";
1519             $limit_cgi  .= "&limit=available";
1520             $limit_desc .= "";
1521         }
1522
1523         # group_OR_limits, prefixed by mc-
1524         # OR every member of the group
1525         elsif ( $this_limit =~ /mc/ ) {
1526             my ($k,$v) = split(/:/, $this_limit,2);
1527             if ( $k !~ /mc-i(tem)?type/ ) {
1528                 # in case the mc-ccode value has complicating chars like ()'s inside it we wrap in quotes
1529                 $this_limit =~ tr/"//d;
1530                 $this_limit = $k.":\"".$v."\"";
1531             }
1532
1533             $group_OR_limits{$k} .= " or " if $group_OR_limits{$k};
1534             $limit_desc      .= " or " if $group_OR_limits{$k};
1535             $group_OR_limits{$k} .= "$this_limit";
1536             $limit_cgi       .= "&limit=" . uri_escape($this_limit);
1537             $limit_desc      .= " $this_limit";
1538         }
1539
1540         # Regular old limits
1541         else {
1542             $limit .= " and " if $limit || $query;
1543             $limit      .= "$this_limit";
1544             $limit_cgi  .= "&limit=" . uri_escape($this_limit);
1545             if ($this_limit =~ /^branch:(.+)/) {
1546                 my $branchcode = $1;
1547                 my $branchname = GetBranchName($branchcode);
1548                 if (defined $branchname) {
1549                     $limit_desc .= " branch:$branchname";
1550                 } else {
1551                     $limit_desc .= " $this_limit";
1552                 }
1553             } else {
1554                 $limit_desc .= " $this_limit";
1555             }
1556         }
1557     }
1558     foreach my $k (keys (%group_OR_limits)) {
1559         $limit .= " and " if ( $query || $limit );
1560         $limit .= "($group_OR_limits{$k})";
1561     }
1562     if ($availability_limit) {
1563         $limit .= " and " if ( $query || $limit );
1564         $limit .= "($availability_limit)";
1565     }
1566
1567     # Normalize the query and limit strings
1568     # This is flawed , means we can't search anything with : in it
1569     # if user wants to do ccl or cql, start the query with that
1570 #    $query =~ s/:/=/g;
1571     $query =~ s/(?<=(ti|au|pb|su|an|kw|mc|nb|ns)):/=/g;
1572     $query =~ s/(?<=(wrdl)):/=/g;
1573     $query =~ s/(?<=(trn|phr)):/=/g;
1574     $limit =~ s/:/=/g;
1575     for ( $query, $query_desc, $limit, $limit_desc ) {
1576         s/  +/ /g;    # remove extra spaces
1577         s/^ //g;     # remove any beginning spaces
1578         s/ $//g;     # remove any ending spaces
1579         s/==/=/g;    # remove double == from query
1580     }
1581     $query_cgi =~ s/^&//; # remove unnecessary & from beginning of the query cgi
1582
1583     for ($query_cgi,$simple_query) {
1584         s/"//g;
1585     }
1586     # append the limit to the query
1587     $query .= " " . $limit;
1588
1589     # Warnings if DEBUG
1590     if ($DEBUG) {
1591         warn "QUERY:" . $query;
1592         warn "QUERY CGI:" . $query_cgi;
1593         warn "QUERY DESC:" . $query_desc;
1594         warn "LIMIT:" . $limit;
1595         warn "LIMIT CGI:" . $limit_cgi;
1596         warn "LIMIT DESC:" . $limit_desc;
1597         warn "---------\nLeave buildQuery\n---------";
1598     }
1599     return (
1600         undef,              $query, $simple_query, $query_cgi,
1601         $query_desc,        $limit, $limit_cgi,    $limit_desc,
1602         $stopwords_removed, $query_type
1603     );
1604 }
1605
1606 =head2 _build_initial_query
1607
1608   ($query, $query_cgi, $query_desc, $previous_operand) = _build_initial_query($initial_query_params);
1609
1610   Build a section of the initial query containing indexes, operators, and operands.
1611
1612 =cut
1613
1614 sub _build_initial_query {
1615     my ($params) = @_;
1616
1617     my $operator = "";
1618     if ($params->{previous_operand}){
1619         #If there is a previous operand, add a supplied operator or the default 'and'
1620         $operator = ($params->{operator}) ? " ".($params->{operator})." " : ' and ';
1621     }
1622
1623     #NOTE: indexes_set is typically set when doing truncation or field weighting
1624     my $operand = ($params->{indexes_set}) ? $params->{parsed_operand} : $params->{index_plus}.$params->{parsed_operand};
1625
1626     #e.g. "kw,wrdl:test"
1627     #e.g. " and kw,wrdl:test"
1628     $params->{query} .= $operator . $operand;
1629
1630     $params->{query_cgi} .= "&op=".uri_escape($operator) if $operator;
1631     $params->{query_cgi} .= "&idx=".uri_escape($params->{index}) if $params->{index};
1632     $params->{query_cgi} .= "&q=".uri_escape($params->{original_operand}) if $params->{original_operand};
1633
1634     #e.g. " and kw,wrdl: test"
1635     $params->{query_desc} .= $operator . $params->{index_plus} . " " . $params->{original_operand};
1636
1637     $params->{previous_operand} = 1 unless $params->{previous_operand}; #If there is no previous operand, mark this as one
1638
1639     return ($params->{query}, $params->{query_cgi}, $params->{query_desc}, $params->{previous_operand});
1640 }
1641
1642 =head2 searchResults
1643
1644   my @search_results = searchResults($search_context, $searchdesc, $hits,
1645                                      $results_per_page, $offset, $scan,
1646                                      @marcresults);
1647
1648 Format results in a form suitable for passing to the template
1649
1650 =cut
1651
1652 # IMO this subroutine is pretty messy still -- it's responsible for
1653 # building the HTML output for the template
1654 sub searchResults {
1655     my ( $search_context, $searchdesc, $hits, $results_per_page, $offset, $scan, $marcresults ) = @_;
1656     my $dbh = C4::Context->dbh;
1657     my @newresults;
1658
1659     require C4::Items;
1660
1661     $search_context = 'opac' if !$search_context || $search_context ne 'intranet';
1662     my ($is_opac, $hidelostitems);
1663     if ($search_context eq 'opac') {
1664         $hidelostitems = C4::Context->preference('hidelostitems');
1665         $is_opac       = 1;
1666     }
1667
1668     #Build branchnames hash
1669     #find branchname
1670     #get branch information.....
1671     my %branches;
1672     my $bsth =$dbh->prepare("SELECT branchcode,branchname FROM branches"); # FIXME : use C4::Branch::GetBranches
1673     $bsth->execute();
1674     while ( my $bdata = $bsth->fetchrow_hashref ) {
1675         $branches{ $bdata->{'branchcode'} } = $bdata->{'branchname'};
1676     }
1677 # FIXME - We build an authorised values hash here, using the default framework
1678 # though it is possible to have different authvals for different fws.
1679
1680     my $shelflocations =GetKohaAuthorisedValues('items.location','');
1681
1682     # get notforloan authorised value list (see $shelflocations  FIXME)
1683     my $notforloan_authorised_value = GetAuthValCode('items.notforloan','');
1684
1685     #Build itemtype hash
1686     #find itemtype & itemtype image
1687     my %itemtypes;
1688     $bsth =
1689       $dbh->prepare(
1690         "SELECT itemtype,description,imageurl,summary,notforloan FROM itemtypes"
1691       );
1692     $bsth->execute();
1693     while ( my $bdata = $bsth->fetchrow_hashref ) {
1694                 foreach (qw(description imageurl summary notforloan)) {
1695                 $itemtypes{ $bdata->{'itemtype'} }->{$_} = $bdata->{$_};
1696                 }
1697     }
1698
1699     #search item field code
1700     my ($itemtag, undef) = &GetMarcFromKohaField( "items.itemnumber", "" );
1701
1702     ## find column names of items related to MARC
1703     my $sth2 = $dbh->prepare("SHOW COLUMNS FROM items");
1704     $sth2->execute;
1705     my %subfieldstosearch;
1706     while ( ( my $column ) = $sth2->fetchrow ) {
1707         my ( $tagfield, $tagsubfield ) =
1708           &GetMarcFromKohaField( "items." . $column, "" );
1709         if ( defined $tagsubfield ) {
1710             $subfieldstosearch{$column} = $tagsubfield;
1711         }
1712     }
1713
1714     # handle which records to actually retrieve
1715     my $times;
1716     if ( $hits && $offset + $results_per_page <= $hits ) {
1717         $times = $offset + $results_per_page;
1718     }
1719     else {
1720         $times = $hits;  # FIXME: if $hits is undefined, why do we want to equal it?
1721     }
1722
1723     my $marcflavour = C4::Context->preference("marcflavour");
1724     # We get the biblionumber position in MARC
1725     my ($bibliotag,$bibliosubf)=GetMarcFromKohaField('biblio.biblionumber','');
1726
1727     # loop through all of the records we've retrieved
1728     for ( my $i = $offset ; $i <= $times - 1 ; $i++ ) {
1729
1730         my $marcrecord;
1731         if ($scan) {
1732             # For Scan searches we built USMARC data
1733             $marcrecord = MARC::Record->new_from_usmarc( $marcresults->[$i]);
1734         } else {
1735             # Normal search, render from Zebra's output
1736             $marcrecord = new_record_from_zebra(
1737                 'biblioserver',
1738                 $marcresults->[$i]
1739             );
1740
1741             if ( ! defined $marcrecord ) {
1742                 warn "ERROR DECODING RECORD - $@: " . $marcresults->[$i];
1743                 next;
1744             }
1745         }
1746
1747         my $fw = $scan
1748              ? undef
1749              : $bibliotag < 10
1750                ? GetFrameworkCode($marcrecord->field($bibliotag)->data)
1751                : GetFrameworkCode($marcrecord->subfield($bibliotag,$bibliosubf));
1752         my $oldbiblio = TransformMarcToKoha( $dbh, $marcrecord, $fw );
1753         $oldbiblio->{subtitle} = GetRecordValue('subtitle', $marcrecord, $fw);
1754         $oldbiblio->{result_number} = $i + 1;
1755
1756         # add imageurl to itemtype if there is one
1757         $oldbiblio->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} );
1758
1759         $oldbiblio->{'authorised_value_images'}  = ($search_context eq 'opac' && C4::Context->preference('AuthorisedValueImages')) || ($search_context eq 'intranet' && C4::Context->preference('StaffAuthorisedValueImages')) ? C4::Items::get_authorised_value_images( C4::Biblio::get_biblio_authorised_values( $oldbiblio->{'biblionumber'}, $marcrecord ) ) : [];
1760                 $oldbiblio->{normalized_upc}  = GetNormalizedUPC(       $marcrecord,$marcflavour);
1761                 $oldbiblio->{normalized_ean}  = GetNormalizedEAN(       $marcrecord,$marcflavour);
1762                 $oldbiblio->{normalized_oclc} = GetNormalizedOCLCNumber($marcrecord,$marcflavour);
1763                 $oldbiblio->{normalized_isbn} = GetNormalizedISBN(undef,$marcrecord,$marcflavour);
1764                 $oldbiblio->{content_identifier_exists} = 1 if ($oldbiblio->{normalized_isbn} or $oldbiblio->{normalized_oclc} or $oldbiblio->{normalized_ean} or $oldbiblio->{normalized_upc});
1765
1766                 # edition information, if any
1767         $oldbiblio->{edition} = $oldbiblio->{editionstatement};
1768                 $oldbiblio->{description} = $itemtypes{ $oldbiblio->{itemtype} }->{description};
1769  # Build summary if there is one (the summary is defined in the itemtypes table)
1770  # FIXME: is this used anywhere, I think it can be commented out? -- JF
1771         if ( $itemtypes{ $oldbiblio->{itemtype} }->{summary} ) {
1772             my $summary = $itemtypes{ $oldbiblio->{itemtype} }->{summary};
1773             my @fields  = $marcrecord->fields();
1774
1775             my $newsummary;
1776             foreach my $line ( "$summary\n" =~ /(.*)\n/g ){
1777                 my $tags = {};
1778                 foreach my $tag ( $line =~ /\[(\d{3}[\w|\d])\]/ ) {
1779                     $tag =~ /(.{3})(.)/;
1780                     if($marcrecord->field($1)){
1781                         my @abc = $marcrecord->field($1)->subfield($2);
1782                         $tags->{$tag} = $#abc + 1 ;
1783                     }
1784                 }
1785
1786                 # We catch how many times to repeat this line
1787                 my $max = 0;
1788                 foreach my $tag (keys(%$tags)){
1789                     $max = $tags->{$tag} if($tags->{$tag} > $max);
1790                  }
1791
1792                 # we replace, and repeat each line
1793                 for (my $i = 0 ; $i < $max ; $i++){
1794                     my $newline = $line;
1795
1796                     foreach my $tag ( $newline =~ /\[(\d{3}[\w|\d])\]/g ) {
1797                         $tag =~ /(.{3})(.)/;
1798
1799                         if($marcrecord->field($1)){
1800                             my @repl = $marcrecord->field($1)->subfield($2);
1801                             my $subfieldvalue = $repl[$i];
1802
1803                             if (! utf8::is_utf8($subfieldvalue)) {
1804                                 utf8::decode($subfieldvalue);
1805                             }
1806
1807                              $newline =~ s/\[$tag\]/$subfieldvalue/g;
1808                         }
1809                     }
1810                     $newsummary .= "$newline\n";
1811                 }
1812             }
1813
1814             $newsummary =~ s/\[(.*?)]//g;
1815             $newsummary =~ s/\n/<br\/>/g;
1816             $oldbiblio->{summary} = $newsummary;
1817         }
1818
1819         # Pull out the items fields
1820         my @fields = $marcrecord->field($itemtag);
1821         my $marcflavor = C4::Context->preference("marcflavour");
1822         # adding linked items that belong to host records
1823         my $analyticsfield = '773';
1824         if ($marcflavor eq 'MARC21' || $marcflavor eq 'NORMARC') {
1825             $analyticsfield = '773';
1826         } elsif ($marcflavor eq 'UNIMARC') {
1827             $analyticsfield = '461';
1828         }
1829         foreach my $hostfield ( $marcrecord->field($analyticsfield)) {
1830             my $hostbiblionumber = $hostfield->subfield("0");
1831             my $linkeditemnumber = $hostfield->subfield("9");
1832             if(!$hostbiblionumber eq undef){
1833                 my $hostbiblio = GetMarcBiblio($hostbiblionumber, 1);
1834                 my ($itemfield, undef) = GetMarcFromKohaField( 'items.itemnumber', GetFrameworkCode($hostbiblionumber) );
1835                 if(!$hostbiblio eq undef){
1836                     my @hostitems = $hostbiblio->field($itemfield);
1837                     foreach my $hostitem (@hostitems){
1838                         if ($hostitem->subfield("9") eq $linkeditemnumber){
1839                             my $linkeditem =$hostitem;
1840                             # append linked items if they exist
1841                             if (!$linkeditem eq undef){
1842                                 push (@fields, $linkeditem);}
1843                         }
1844                     }
1845                 }
1846             }
1847         }
1848
1849         # Setting item statuses for display
1850         my @available_items_loop;
1851         my @onloan_items_loop;
1852         my @other_items_loop;
1853
1854         my $available_items;
1855         my $onloan_items;
1856         my $other_items;
1857
1858         my $ordered_count         = 0;
1859         my $available_count       = 0;
1860         my $onloan_count          = 0;
1861         my $longoverdue_count     = 0;
1862         my $other_count           = 0;
1863         my $withdrawn_count        = 0;
1864         my $itemlost_count        = 0;
1865         my $hideatopac_count      = 0;
1866         my $itembinding_count     = 0;
1867         my $itemdamaged_count     = 0;
1868         my $item_in_transit_count = 0;
1869         my $can_place_holds       = 0;
1870         my $item_onhold_count     = 0;
1871         my $notforloan_count      = 0;
1872         my $items_count           = scalar(@fields);
1873         my $maxitems_pref = C4::Context->preference('maxItemsinSearchResults');
1874         my $maxitems = $maxitems_pref ? $maxitems_pref - 1 : 1;
1875         my @hiddenitems; # hidden itemnumbers based on OpacHiddenItems syspref
1876
1877         # loop through every item
1878         foreach my $field (@fields) {
1879             my $item;
1880
1881             # populate the items hash
1882             foreach my $code ( keys %subfieldstosearch ) {
1883                 $item->{$code} = $field->subfield( $subfieldstosearch{$code} );
1884             }
1885             $item->{description} = $itemtypes{ $item->{itype} }{description};
1886
1887                 # OPAC hidden items
1888             if ($is_opac) {
1889                 # hidden because lost
1890                 if ($hidelostitems && $item->{itemlost}) {
1891                     $hideatopac_count++;
1892                     next;
1893                 }
1894                 # hidden based on OpacHiddenItems syspref
1895                 my @hi = C4::Items::GetHiddenItemnumbers($item);
1896                 if (scalar @hi) {
1897                     push @hiddenitems, @hi;
1898                     $hideatopac_count++;
1899                     next;
1900                 }
1901             }
1902
1903             my $hbranch     = C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch' ? 'homebranch'    : 'holdingbranch';
1904             my $otherbranch = C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch' ? 'holdingbranch' : 'homebranch';
1905
1906             # set item's branch name, use HomeOrHoldingBranch syspref first, fall back to the other one
1907             if ($item->{$hbranch}) {
1908                 $item->{'branchname'} = $branches{$item->{$hbranch}};
1909             }
1910             elsif ($item->{$otherbranch}) {     # Last resort
1911                 $item->{'branchname'} = $branches{$item->{$otherbranch}};
1912             }
1913
1914                         my $prefix = $item->{$hbranch} . '--' . $item->{location} . $item->{itype} . $item->{itemcallnumber};
1915 # For each grouping of items (onloan, available, unavailable), we build a key to store relevant info about that item
1916             my $userenv = C4::Context->userenv;
1917             if ( $item->{onloan} && !(C4::Members::GetHideLostItemsPreference($userenv->{'number'}) && $item->{itemlost}) ) {
1918                 $onloan_count++;
1919                                 my $key = $prefix . $item->{onloan} . $item->{barcode};
1920                                 $onloan_items->{$key}->{due_date} = format_date($item->{onloan});
1921                                 $onloan_items->{$key}->{count}++ if $item->{$hbranch};
1922                                 $onloan_items->{$key}->{branchname} = $item->{branchname};
1923                                 $onloan_items->{$key}->{location} = $shelflocations->{ $item->{location} };
1924                                 $onloan_items->{$key}->{itemcallnumber} = $item->{itemcallnumber};
1925                                 $onloan_items->{$key}->{description} = $item->{description};
1926                                 $onloan_items->{$key}->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $item->{itype} }->{imageurl} );
1927                 # if something's checked out and lost, mark it as 'long overdue'
1928                 if ( $item->{itemlost} ) {
1929                     $onloan_items->{$prefix}->{longoverdue}++;
1930                     $longoverdue_count++;
1931                 } else {        # can place holds as long as item isn't lost
1932                     $can_place_holds = 1;
1933                 }
1934             }
1935
1936          # items not on loan, but still unavailable ( lost, withdrawn, damaged )
1937             else {
1938
1939                 # item is on order
1940                 if ( $item->{notforloan} < 0 ) {
1941                     $ordered_count++;
1942                 } elsif ( $item->{notforloan} > 0 ) {
1943                     $notforloan_count++;
1944                 }
1945
1946                 # is item in transit?
1947                 my $transfertwhen = '';
1948                 my ($transfertfrom, $transfertto);
1949
1950                 # is item on the reserve shelf?
1951                 my $reservestatus = '';
1952
1953                 unless ($item->{withdrawn}
1954                         || $item->{itemlost}
1955                         || $item->{damaged}
1956                         || $item->{notforloan}
1957                         || $items_count > 20) {
1958
1959                     # A couple heuristics to limit how many times
1960                     # we query the database for item transfer information, sacrificing
1961                     # accuracy in some cases for speed;
1962                     #
1963                     # 1. don't query if item has one of the other statuses
1964                     # 2. don't check transit status if the bib has
1965                     #    more than 20 items
1966                     #
1967                     # FIXME: to avoid having the query the database like this, and to make
1968                     #        the in transit status count as unavailable for search limiting,
1969                     #        should map transit status to record indexed in Zebra.
1970                     #
1971                     ($transfertwhen, $transfertfrom, $transfertto) = C4::Circulation::GetTransfers($item->{itemnumber});
1972                     $reservestatus = C4::Reserves::GetReserveStatus( $item->{itemnumber}, $oldbiblio->{biblionumber} );
1973                 }
1974
1975                 # item is withdrawn, lost, damaged, not for loan, reserved or in transit
1976                 if (   $item->{withdrawn}
1977                     || $item->{itemlost}
1978                     || $item->{damaged}
1979                     || $item->{notforloan}
1980                     || $reservestatus eq 'Waiting'
1981                     || ($transfertwhen ne ''))
1982                 {
1983                     $withdrawn_count++        if $item->{withdrawn};
1984                     $itemlost_count++        if $item->{itemlost};
1985                     $itemdamaged_count++     if $item->{damaged};
1986                     $item_in_transit_count++ if $transfertwhen ne '';
1987                     $item_onhold_count++     if $reservestatus eq 'Waiting';
1988                     $item->{status} = $item->{withdrawn} . "-" . $item->{itemlost} . "-" . $item->{damaged} . "-" . $item->{notforloan};
1989
1990                     # can place a hold on a item if
1991                     # not lost nor withdrawn
1992                     # not damaged unless AllowHoldsOnDamagedItems is true
1993                     # item is either for loan or on order (notforloan < 0)
1994                     $can_place_holds = 1
1995                       if (
1996                            !$item->{itemlost}
1997                         && !$item->{withdrawn}
1998                         && ( !$item->{damaged} || C4::Context->preference('AllowHoldsOnDamagedItems') )
1999                         && ( !$item->{notforloan} || $item->{notforloan} < 0 )
2000                       );
2001
2002                     $other_count++;
2003
2004                     my $key = $prefix . $item->{status};
2005                     foreach (qw(withdrawn itemlost damaged branchname itemcallnumber)) {
2006                         $other_items->{$key}->{$_} = $item->{$_};
2007                     }
2008                     $other_items->{$key}->{intransit} = ( $transfertwhen ne '' ) ? 1 : 0;
2009                     $other_items->{$key}->{onhold} = ($reservestatus) ? 1 : 0;
2010                     $other_items->{$key}->{notforloan} = GetAuthorisedValueDesc('','',$item->{notforloan},'','',$notforloan_authorised_value) if $notforloan_authorised_value and $item->{notforloan};
2011                                         $other_items->{$key}->{count}++ if $item->{$hbranch};
2012                                         $other_items->{$key}->{location} = $shelflocations->{ $item->{location} };
2013                                         $other_items->{$key}->{description} = $item->{description};
2014                                         $other_items->{$key}->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $item->{itype} }->{imageurl} );
2015                 }
2016                 # item is available
2017                 else {
2018                     $can_place_holds = 1;
2019                     $available_count++;
2020                                         $available_items->{$prefix}->{count}++ if $item->{$hbranch};
2021                                         foreach (qw(branchname itemcallnumber description)) {
2022                         $available_items->{$prefix}->{$_} = $item->{$_};
2023                                         }
2024                                         $available_items->{$prefix}->{location} = $shelflocations->{ $item->{location} };
2025                                         $available_items->{$prefix}->{imageurl} = getitemtypeimagelocation( $search_context, $itemtypes{ $item->{itype} }->{imageurl} );
2026                 }
2027             }
2028         }    # notforloan, item level and biblioitem level
2029
2030         # if all items are hidden, do not show the record
2031         if ($items_count > 0 && $hideatopac_count == $items_count) {
2032             next;
2033         }
2034
2035         my ( $availableitemscount, $onloanitemscount, $otheritemscount );
2036         for my $key ( sort keys %$onloan_items ) {
2037             (++$onloanitemscount > $maxitems) and last;
2038             push @onloan_items_loop, $onloan_items->{$key};
2039         }
2040         for my $key ( sort keys %$other_items ) {
2041             (++$otheritemscount > $maxitems) and last;
2042             push @other_items_loop, $other_items->{$key};
2043         }
2044         for my $key ( sort keys %$available_items ) {
2045             (++$availableitemscount > $maxitems) and last;
2046             push @available_items_loop, $available_items->{$key}
2047         }
2048
2049         # XSLT processing of some stuff
2050         use C4::Charset;
2051         SetUTF8Flag($marcrecord);
2052         warn $marcrecord->as_formatted if $DEBUG;
2053         my $interface = $search_context eq 'opac' ? 'OPAC' : '';
2054         if (!$scan && C4::Context->preference($interface . "XSLTResultsDisplay")) {
2055             $oldbiblio->{XSLTResultsRecord} = XSLTParse4Display($oldbiblio->{biblionumber}, $marcrecord, $interface."XSLTResultsDisplay", 1, \@hiddenitems);
2056             # the last parameter tells Koha to clean up the problematic ampersand entities that Zebra outputs
2057         }
2058
2059         # if biblio level itypes are used and itemtype is notforloan, it can't be reserved either
2060         if (!C4::Context->preference("item-level_itypes")) {
2061             if ($itemtypes{ $oldbiblio->{itemtype} }->{notforloan}) {
2062                 $can_place_holds = 0;
2063             }
2064         }
2065         $oldbiblio->{norequests} = 1 unless $can_place_holds;
2066         $oldbiblio->{itemsplural}          = 1 if $items_count > 1;
2067         $oldbiblio->{items_count}          = $items_count;
2068         $oldbiblio->{available_items_loop} = \@available_items_loop;
2069         $oldbiblio->{onloan_items_loop}    = \@onloan_items_loop;
2070         $oldbiblio->{other_items_loop}     = \@other_items_loop;
2071         $oldbiblio->{availablecount}       = $available_count;
2072         $oldbiblio->{availableplural}      = 1 if $available_count > 1;
2073         $oldbiblio->{onloancount}          = $onloan_count;
2074         $oldbiblio->{onloanplural}         = 1 if $onloan_count > 1;
2075         $oldbiblio->{othercount}           = $other_count;
2076         $oldbiblio->{otherplural}          = 1 if $other_count > 1;
2077         $oldbiblio->{withdrawncount}        = $withdrawn_count;
2078         $oldbiblio->{itemlostcount}        = $itemlost_count;
2079         $oldbiblio->{damagedcount}         = $itemdamaged_count;
2080         $oldbiblio->{intransitcount}       = $item_in_transit_count;
2081         $oldbiblio->{onholdcount}          = $item_onhold_count;
2082         $oldbiblio->{orderedcount}         = $ordered_count;
2083         $oldbiblio->{notforloancount}      = $notforloan_count;
2084
2085         if (C4::Context->preference("AlternateHoldingsField") && $items_count == 0) {
2086             my $fieldspec = C4::Context->preference("AlternateHoldingsField");
2087             my $subfields = substr $fieldspec, 3;
2088             my $holdingsep = C4::Context->preference("AlternateHoldingsSeparator") || ' ';
2089             my @alternateholdingsinfo = ();
2090             my @holdingsfields = $marcrecord->field(substr $fieldspec, 0, 3);
2091             my $alternateholdingscount = 0;
2092
2093             for my $field (@holdingsfields) {
2094                 my %holding = ( holding => '' );
2095                 my $havesubfield = 0;
2096                 for my $subfield ($field->subfields()) {
2097                     if ((index $subfields, $$subfield[0]) >= 0) {
2098                         $holding{'holding'} .= $holdingsep if (length $holding{'holding'} > 0);
2099                         $holding{'holding'} .= $$subfield[1];
2100                         $havesubfield++;
2101                     }
2102                 }
2103                 if ($havesubfield) {
2104                     push(@alternateholdingsinfo, \%holding);
2105                     $alternateholdingscount++;
2106                 }
2107             }
2108
2109             $oldbiblio->{'ALTERNATEHOLDINGS'} = \@alternateholdingsinfo;
2110             $oldbiblio->{'alternateholdings_count'} = $alternateholdingscount;
2111         }
2112
2113         push( @newresults, $oldbiblio );
2114     }
2115
2116     return @newresults;
2117 }
2118
2119 =head2 SearchAcquisitions
2120     Search for acquisitions
2121 =cut
2122
2123 sub SearchAcquisitions{
2124     my ($datebegin, $dateend, $itemtypes,$criteria, $orderby) = @_;
2125
2126     my $dbh=C4::Context->dbh;
2127     # Variable initialization
2128     my $str=qq|
2129     SELECT marcxml
2130     FROM biblio
2131     LEFT JOIN biblioitems ON biblioitems.biblionumber=biblio.biblionumber
2132     LEFT JOIN items ON items.biblionumber=biblio.biblionumber
2133     WHERE dateaccessioned BETWEEN ? AND ?
2134     |;
2135
2136     my (@params,@loopcriteria);
2137
2138     push @params, $datebegin->output("iso");
2139     push @params, $dateend->output("iso");
2140
2141     if (scalar(@$itemtypes)>0 and $criteria ne "itemtype" ){
2142         if(C4::Context->preference("item-level_itypes")){
2143             $str .= "AND items.itype IN (?".( ',?' x scalar @$itemtypes - 1 ).") ";
2144         }else{
2145             $str .= "AND biblioitems.itemtype IN (?".( ',?' x scalar @$itemtypes - 1 ).") ";
2146         }
2147         push @params, @$itemtypes;
2148     }
2149
2150     if ($criteria =~/itemtype/){
2151         if(C4::Context->preference("item-level_itypes")){
2152             $str .= "AND items.itype=? ";
2153         }else{
2154             $str .= "AND biblioitems.itemtype=? ";
2155         }
2156
2157         if(scalar(@$itemtypes) == 0){
2158             my $itypes = GetItemTypes();
2159             for my $key (keys %$itypes){
2160                 push @$itemtypes, $key;
2161             }
2162         }
2163
2164         @loopcriteria= @$itemtypes;
2165     }elsif ($criteria=~/itemcallnumber/){
2166         $str .= "AND (items.itemcallnumber LIKE CONCAT(?,'%')
2167                  OR items.itemcallnumber is NULL
2168                  OR items.itemcallnumber = '')";
2169
2170         @loopcriteria = ("AA".."ZZ", "") unless (scalar(@loopcriteria)>0);
2171     }else {
2172         $str .= "AND biblio.title LIKE CONCAT(?,'%') ";
2173         @loopcriteria = ("A".."z") unless (scalar(@loopcriteria)>0);
2174     }
2175
2176     if ($orderby =~ /date_desc/){
2177         $str.=" ORDER BY dateaccessioned DESC";
2178     } else {
2179         $str.=" ORDER BY title";
2180     }
2181
2182     my $qdataacquisitions=$dbh->prepare($str);
2183
2184     my @loopacquisitions;
2185     foreach my $value(@loopcriteria){
2186         push @params,$value;
2187         my %cell;
2188         $cell{"title"}=$value;
2189         $cell{"titlecode"}=$value;
2190
2191         eval{$qdataacquisitions->execute(@params);};
2192
2193         if ($@){ warn "recentacquisitions Error :$@";}
2194         else {
2195             my @loopdata;
2196             while (my $data=$qdataacquisitions->fetchrow_hashref){
2197                 push @loopdata, {"summary"=>GetBiblioSummary( $data->{'marcxml'} ) };
2198             }
2199             $cell{"loopdata"}=\@loopdata;
2200         }
2201         push @loopacquisitions,\%cell if (scalar(@{$cell{loopdata}})>0);
2202         pop @params;
2203     }
2204     $qdataacquisitions->finish;
2205     return \@loopacquisitions;
2206 }
2207
2208 =head2 enabled_staff_search_views
2209
2210 %hash = enabled_staff_search_views()
2211
2212 This function returns a hash that contains three flags obtained from the system
2213 preferences, used to determine whether a particular staff search results view
2214 is enabled.
2215
2216 =over 2
2217
2218 =item C<Output arg:>
2219
2220     * $hash{can_view_MARC} is true only if the MARC view is enabled
2221     * $hash{can_view_ISBD} is true only if the ISBD view is enabled
2222     * $hash{can_view_labeledMARC} is true only if the Labeled MARC view is enabled
2223
2224 =item C<usage in the script:>
2225
2226 =back
2227
2228 $template->param ( C4::Search::enabled_staff_search_views );
2229
2230 =cut
2231
2232 sub enabled_staff_search_views
2233 {
2234         return (
2235                 can_view_MARC                   => C4::Context->preference('viewMARC'),                 # 1 if the staff search allows the MARC view
2236                 can_view_ISBD                   => C4::Context->preference('viewISBD'),                 # 1 if the staff search allows the ISBD view
2237                 can_view_labeledMARC    => C4::Context->preference('viewLabeledMARC'),  # 1 if the staff search allows the Labeled MARC view
2238         );
2239 }
2240
2241 sub PurgeSearchHistory{
2242     my ($pSearchhistory)=@_;
2243     my $dbh = C4::Context->dbh;
2244     my $sth = $dbh->prepare("DELETE FROM search_history WHERE time < DATE_SUB( NOW(), INTERVAL ? DAY )");
2245     $sth->execute($pSearchhistory) or die $dbh->errstr;
2246 }
2247
2248 =head2 z3950_search_args
2249
2250 $arrayref = z3950_search_args($matchpoints)
2251
2252 This function returns an array reference that contains the search parameters to be
2253 passed to the Z39.50 search script (z3950_search.pl). The array elements
2254 are hash refs whose keys are name and value, and whose values are the
2255 name of a search parameter, the value of that search parameter and the URL encoded
2256 value of that parameter.
2257
2258 The search parameter names are lccn, isbn, issn, title, author, dewey and subject.
2259
2260 The search parameter values are obtained from the bibliographic record whose
2261 data is in a hash reference in $matchpoints, as returned by Biblio::GetBiblioData().
2262
2263 If $matchpoints is a scalar, it is assumed to be an unnamed query descriptor, e.g.
2264 a general purpose search argument. In this case, the returned array contains only
2265 entry: the key is 'title' and the value is derived from $matchpoints.
2266
2267 If a search parameter value is undefined or empty, it is not included in the returned
2268 array.
2269
2270 The returned array reference may be passed directly to the template parameters.
2271
2272 =over 2
2273
2274 =item C<Output arg:>
2275
2276     * $array containing hash refs as described above
2277
2278 =item C<usage in the script:>
2279
2280 =back
2281
2282 $data = Biblio::GetBiblioData($bibno);
2283 $template->param ( MYLOOP => C4::Search::z3950_search_args($data) )
2284
2285 *OR*
2286
2287 $template->param ( MYLOOP => C4::Search::z3950_search_args($searchscalar) )
2288
2289 =cut
2290
2291 sub z3950_search_args {
2292     my $bibrec = shift;
2293
2294     my $isbn_string = ref( $bibrec ) ? $bibrec->{title} : $bibrec;
2295     my $isbn = Business::ISBN->new( $isbn_string );
2296
2297     if (defined $isbn && $isbn->is_valid)
2298     {
2299         if ( ref($bibrec) ) {
2300             $bibrec->{isbn} = $isbn_string;
2301             $bibrec->{title} = undef;
2302         } else {
2303             $bibrec = { isbn => $isbn_string };
2304         }
2305     }
2306     else {
2307         $bibrec = { title => $bibrec } if !ref $bibrec;
2308     }
2309     my $array = [];
2310     for my $field (qw/ lccn isbn issn title author dewey subject /)
2311     {
2312         push @$array, { name => $field, value => $bibrec->{$field} }
2313           if defined $bibrec->{$field};
2314     }
2315     return $array;
2316 }
2317
2318 =head2 GetDistinctValues($field);
2319
2320 C<$field> is a reference to the fields array
2321
2322 =cut
2323
2324 sub GetDistinctValues {
2325     my ($fieldname,$string)=@_;
2326     # returns a reference to a hash of references to branches...
2327     if ($fieldname=~/\./){
2328                         my ($table,$column)=split /\./, $fieldname;
2329                         my $dbh = C4::Context->dbh;
2330                         warn "select DISTINCT($column) as value, count(*) as cnt from $table group by lib order by $column " if $DEBUG;
2331                         my $sth = $dbh->prepare("select DISTINCT($column) as value, count(*) as cnt from $table ".($string?" where $column like \"$string%\"":"")."group by value order by $column ");
2332                         $sth->execute;
2333                         my $elements=$sth->fetchall_arrayref({});
2334                         return $elements;
2335    }
2336    else {
2337                 $string||= qq("");
2338                 my @servers=qw<biblioserver authorityserver>;
2339                 my (@zconns,@results);
2340         for ( my $i = 0 ; $i < @servers ; $i++ ) {
2341                 $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
2342                         $results[$i] =
2343                       $zconns[$i]->scan(
2344                         ZOOM::Query::CCL2RPN->new( qq"$fieldname $string", $zconns[$i])
2345                       );
2346                 }
2347                 # The big moment: asynchronously retrieve results from all servers
2348                 my @elements;
2349         _ZOOM_event_loop(
2350             \@zconns,
2351             \@results,
2352             sub {
2353                 my ( $i, $size ) = @_;
2354                 for ( my $j = 0 ; $j < $size ; $j++ ) {
2355                     my %hashscan;
2356                     @hashscan{qw(value cnt)} =
2357                       $results[ $i - 1 ]->display_term($j);
2358                     push @elements, \%hashscan;
2359                 }
2360             }
2361         );
2362                 return \@elements;
2363    }
2364 }
2365
2366 =head2 _ZOOM_event_loop
2367
2368     _ZOOM_event_loop(\@zconns, \@results, sub {
2369         my ( $i, $size ) = @_;
2370         ....
2371     } );
2372
2373 Processes a ZOOM event loop and passes control to a closure for
2374 processing the results, and destroying the resultsets.
2375
2376 =cut
2377
2378 sub _ZOOM_event_loop {
2379     my ($zconns, $results, $callback) = @_;
2380     while ( ( my $i = ZOOM::event( $zconns ) ) != 0 ) {
2381         my $ev = $zconns->[ $i - 1 ]->last_event();
2382         if ( $ev == ZOOM::Event::ZEND ) {
2383             next unless $results->[ $i - 1 ];
2384             my $size = $results->[ $i - 1 ]->size();
2385             if ( $size > 0 ) {
2386                 $callback->($i, $size);
2387             }
2388         }
2389     }
2390
2391     foreach my $result (@$results) {
2392         $result->destroy();
2393     }
2394 }
2395
2396 =head2 new_record_from_zebra
2397
2398 Given raw data from a Zebra result set, return a MARC::Record object
2399
2400 This helper function is needed to take into account all the involved
2401 system preferences and configuration variables to properly create the
2402 MARC::Record object.
2403
2404 If we are using GRS-1, then the raw data we get from Zebra should be USMARC
2405 data. If we are using DOM, then it has to be MARCXML.
2406
2407 =cut
2408
2409 sub new_record_from_zebra {
2410
2411     my $server   = shift;
2412     my $raw_data = shift;
2413     # Set the default indexing modes
2414     my $index_mode = ( $server eq 'biblioserver' )
2415                         ? C4::Context->config('zebra_bib_index_mode') // 'grs1'
2416                         : C4::Context->config('zebra_auth_index_mode') // 'dom';
2417
2418     my $marc_record =  eval {
2419         if ( $index_mode eq 'dom' ) {
2420             MARC::Record->new_from_xml( $raw_data, 'UTF-8' );
2421         } else {
2422             MARC::Record->new_from_usmarc( $raw_data );
2423         }
2424     };
2425
2426     if ($@) {
2427         return;
2428     } else {
2429         return $marc_record;
2430     }
2431
2432 }
2433
2434 END { }    # module clean-up code here (global destructor)
2435
2436 1;
2437 __END__
2438
2439 =head1 AUTHOR
2440
2441 Koha Development Team <http://koha-community.org/>
2442
2443 =cut