3 # This file is part of Koha.
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
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.
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
21 use C4::Biblio; # GetMarcFromKohaField
22 use C4::Koha; # getFacets
24 use C4::Dates qw(format_date);
26 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $DEBUG);
28 # set the version for version checking
31 $DEBUG = ($ENV{DEBUG}) ? 1 : 0;
36 C4::Search - Functions for searching the Koha catalog.
40 See opac/opac-search.pl or catalogue/search.pl for example of usage
44 This module provides searching functions for Koha's bibliographic databases
62 # make all your functions, whether exported or not;
64 =head2 findseealso($dbh,$fields);
66 C<$dbh> is a link to the DB handler.
69 my $dbh =C4::Context->dbh;
71 C<$fields> is a reference to the fields array
73 This function modifies the @$fields array and adds related fields to search on.
75 FIXME: this function is probably deprecated in Koha 3
80 my ( $dbh, $fields ) = @_;
81 my $tagslib = GetMarcStructure(1);
82 for ( my $i = 0 ; $i <= $#{$fields} ; $i++ ) {
83 my ($tag) = substr( @$fields[$i], 1, 3 );
84 my ($subfield) = substr( @$fields[$i], 4, 1 );
85 @$fields[$i] .= ',' . $tagslib->{$tag}->{$subfield}->{seealso}
86 if ( $tagslib->{$tag}->{$subfield}->{seealso} );
92 ($biblionumber,$biblionumber,$title) = FindDuplicate($record);
94 This function attempts to find duplicate records using a hard-coded, fairly simplistic algorithm
100 my $dbh = C4::Context->dbh;
101 my $result = TransformMarcToKoha( $dbh, $record, '' );
106 my ( $biblionumber, $title );
108 # search duplicate on ISBN, easy and fast..
109 # ... normalize first
110 if ( $result->{isbn} ) {
111 $result->{isbn} =~ s/\(.*$//;
112 $result->{isbn} =~ s/\s+$//;
113 $query = "isbn=$result->{isbn}";
116 $result->{title} =~ s /\\//g;
117 $result->{title} =~ s /\"//g;
118 $result->{title} =~ s /\(//g;
119 $result->{title} =~ s /\)//g;
121 # FIXME: instead of removing operators, could just do
122 # quotes around the value
123 $result->{title} =~ s/(and|or|not)//g;
124 $query = "ti,ext=$result->{title}";
125 $query .= " and itemtype=$result->{itemtype}"
126 if ( $result->{itemtype} );
127 if ( $result->{author} ) {
128 $result->{author} =~ s /\\//g;
129 $result->{author} =~ s /\"//g;
130 $result->{author} =~ s /\(//g;
131 $result->{author} =~ s /\)//g;
133 # remove valid operators
134 $result->{author} =~ s/(and|or|not)//g;
135 $query .= " and au,ext=$result->{author}";
139 # FIXME: add error handling
140 my ( $error, $searchresults ) = SimpleSearch($query); # FIXME :: hardcoded !
142 foreach my $possible_duplicate_record (@$searchresults) {
144 MARC::Record->new_from_usmarc($possible_duplicate_record);
145 my $result = TransformMarcToKoha( $dbh, $marcrecord, '' );
147 # FIXME :: why 2 $biblionumber ?
149 push @results, $result->{'biblionumber'};
150 push @results, $result->{'title'};
158 ($error,$results) = SimpleSearch($query,@servers);
160 This function provides a simple search API on the bibliographic catalog
166 * $query can be a simple keyword or a complete CCL query
167 * @servers is optional. Defaults to biblioserver as found in koha-conf.xml
170 * $error is a empty unless an error is detected
171 * \@results is an array of records.
173 =item C<usage in the script:>
177 my ($error, $marcresults) = SimpleSearch($query);
179 if (defined $error) {
180 $template->param(query_error => $error);
181 warn "error: ".$error;
182 output_html_with_http_headers $input, $cookie, $template->output;
186 my $hits = scalar @$marcresults;
189 for(my $i=0;$i<$hits;$i++) {
191 my $marcrecord = MARC::File::USMARC::decode($marcresults->[$i]);
192 my $biblio = TransformMarcToKoha(C4::Context->dbh,$marcrecord,'');
194 #build the hash for the template.
195 $resultsloop{highlight} = ($i % 2)?(1):(0);
196 $resultsloop{title} = $biblio->{'title'};
197 $resultsloop{subtitle} = $biblio->{'subtitle'};
198 $resultsloop{biblionumber} = $biblio->{'biblionumber'};
199 $resultsloop{author} = $biblio->{'author'};
200 $resultsloop{publishercode} = $biblio->{'publishercode'};
201 $resultsloop{publicationyear} = $biblio->{'publicationyear'};
203 push @results, \%resultsloop;
206 $template->param(result=>\@results);
212 if ( C4::Context->preference('NoZebra') ) {
213 my $result = NZorder( NZanalyse($query) )->{'biblioserver'};
216 && $result->{hits} > 0 ? $result->{'RECORDS'} : [] );
217 return ( undef, $search_result );
224 return ( "No query entered", undef ) unless $query;
226 # FIXME hardcoded value. See catalog/search.pl & opac-search.pl too.
227 @servers = ("biblioserver") unless @servers;
229 # Initialize & Search Zebra
230 for ( my $i = 0 ; $i < @servers ; $i++ ) {
232 $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
235 ->search( new ZOOM::Query::CCL2RPN( $query, $zconns[$i] ) );
239 $zconns[$i]->errmsg() . " ("
240 . $zconns[$i]->errcode() . ") "
241 . $zconns[$i]->addinfo() . " "
242 . $zconns[$i]->diagset();
244 return ( $error, undef ) if $zconns[$i]->errcode();
248 # caught a ZOOM::Exception
252 . $@->addinfo() . " "
255 return ( $error, undef );
260 while ( ( my $i = ZOOM::event( \@zconns ) ) != 0 ) {
261 $ev = $zconns[ $i - 1 ]->last_event();
262 if ( $ev == ZOOM::Event::ZEND ) {
263 $hits = $tmpresults[ $i - 1 ]->size();
266 for ( my $j = 0 ; $j < $hits ; $j++ ) {
267 my $record = $tmpresults[ $i - 1 ]->record($j)->raw();
268 push @results, $record;
273 return ( undef, \@results );
279 ( undef, $results_hashref, \@facets_loop ) = getRecords (
281 $koha_query, $simple_query, $sort_by_ref, $servers_ref,
282 $results_per_page, $offset, $expanded_facet, $branches,
286 The all singing, all dancing, multi-server, asynchronous, scanning,
287 searching, record nabbing, facet-building
289 See verbse embedded documentation.
295 $koha_query, $simple_query, $sort_by_ref, $servers_ref,
296 $results_per_page, $offset, $expanded_facet, $branches,
300 my @servers = @$servers_ref;
301 my @sort_by = @$sort_by_ref;
303 # Initialize variables for the ZOOM connection and results object
307 my $results_hashref = ();
309 # Initialize variables for the faceted results objects
310 my $facets_counter = ();
311 my $facets_info = ();
312 my $facets = getFacets();
315 ; # stores the ref to array of hashes for template facets loop
317 ### LOOP THROUGH THE SERVERS
318 for ( my $i = 0 ; $i < @servers ; $i++ ) {
319 $zconns[$i] = C4::Context->Zconn( $servers[$i], 1 );
321 # perform the search, create the results objects
322 # if this is a local search, use the $koha-query, if it's a federated one, use the federated-query
324 if ( $servers[$i] =~ /biblioserver/ ) {
325 $query_to_use = $koha_query;
328 $query_to_use = $simple_query;
331 #$query_to_use = $simple_query if $scan;
332 warn $simple_query if ( $scan and $DEBUG );
334 # Check if we've got a query_type defined, if so, use it
338 if ( $query_type =~ /^ccl/ ) {
340 s/\:/\=/g; # change : to = last minute (FIXME)
343 new ZOOM::Query::CCL2RPN( $query_to_use, $zconns[$i] )
346 elsif ( $query_type =~ /^cql/ ) {
349 new ZOOM::Query::CQL( $query_to_use, $zconns[$i] ) );
351 elsif ( $query_type =~ /^pqf/ ) {
354 new ZOOM::Query::PQF( $query_to_use, $zconns[$i] ) );
361 new ZOOM::Query::CCL2RPN( $query_to_use, $zconns[$i] )
367 new ZOOM::Query::CCL2RPN( $query_to_use, $zconns[$i] )
373 warn "WARNING: query problem with $query_to_use " . $@;
376 # Concatenate the sort_by limits and pass them to the results object
377 # Note: sort will override rank
379 foreach my $sort (@sort_by) {
380 if ( $sort eq "author_az" ) {
381 $sort_by .= "1=1003 <i ";
383 elsif ( $sort eq "author_za" ) {
384 $sort_by .= "1=1003 >i ";
386 elsif ( $sort eq "popularity_asc" ) {
387 $sort_by .= "1=9003 <i ";
389 elsif ( $sort eq "popularity_dsc" ) {
390 $sort_by .= "1=9003 >i ";
392 elsif ( $sort eq "call_number_asc" ) {
393 $sort_by .= "1=20 <i ";
395 elsif ( $sort eq "call_number_dsc" ) {
396 $sort_by .= "1=20 >i ";
398 elsif ( $sort eq "pubdate_asc" ) {
399 $sort_by .= "1=31 <i ";
401 elsif ( $sort eq "pubdate_dsc" ) {
402 $sort_by .= "1=31 >i ";
404 elsif ( $sort eq "acqdate_asc" ) {
405 $sort_by .= "1=32 <i ";
407 elsif ( $sort eq "acqdate_dsc" ) {
408 $sort_by .= "1=32 >i ";
410 elsif ( $sort eq "title_az" ) {
411 $sort_by .= "1=4 <i ";
413 elsif ( $sort eq "title_za" ) {
414 $sort_by .= "1=4 >i ";
418 if ( $results[$i]->sort( "yaz", $sort_by ) < 0 ) {
419 warn "WARNING sort $sort_by failed";
422 } # finished looping through servers
424 # The big moment: asynchronously retrieve results from all servers
425 while ( ( my $i = ZOOM::event( \@zconns ) ) != 0 ) {
426 my $ev = $zconns[ $i - 1 ]->last_event();
427 if ( $ev == ZOOM::Event::ZEND ) {
428 next unless $results[ $i - 1 ];
429 my $size = $results[ $i - 1 ]->size();
433 # loop through the results
434 $results_hash->{'hits'} = $size;
436 if ( $offset + $results_per_page <= $size ) {
437 $times = $offset + $results_per_page;
442 for ( my $j = $offset ; $j < $times ; $j++ ) {
447 ## Check if it's an index scan
449 my ( $term, $occ ) = $results[ $i - 1 ]->term($j);
451 # here we create a minimal MARC record and hand it off to the
452 # template just like a normal result ... perhaps not ideal, but
454 my $tmprecord = MARC::Record->new();
455 $tmprecord->encoding('UTF-8');
459 # the minimal record in author/title (depending on MARC flavour)
460 if ( C4::Context->preference("marcflavour") eq
463 $tmptitle = MARC::Field->new(
471 MARC::Field->new( '245', ' ', ' ', a => $term, );
473 MARC::Field->new( '100', ' ', ' ', a => $occ, );
475 $tmprecord->append_fields($tmptitle);
476 $tmprecord->append_fields($tmpauthor);
477 $results_hash->{'RECORDS'}[$j] =
478 $tmprecord->as_usmarc();
483 $record = $results[ $i - 1 ]->record($j)->raw();
485 # warn "RECORD $j:".$record;
486 $results_hash->{'RECORDS'}[$j] = $record;
488 # Fill the facets while we're looping, but only for the biblioserver
489 $facet_record = MARC::Record->new_from_usmarc($record)
490 if $servers[ $i - 1 ] =~ /biblioserver/;
492 #warn $servers[$i-1]."\n".$record; #.$facet_record->title();
494 for ( my $k = 0 ; $k <= @$facets ; $k++ ) {
496 if ( $facets->[$k] ) {
498 for my $tag ( @{ $facets->[$k]->{'tags'} } )
501 $facet_record->field($tag);
503 for my $field (@fields) {
504 my @subfields = $field->subfields();
505 for my $subfield (@subfields) {
506 my ( $code, $data ) = @$subfield;
508 $facets->[$k]->{'subfield'} )
510 $facets_counter->{ $facets->[$k]
516 $facets_info->{ $facets->[$k]
517 ->{'link_value'} }->{'label_value'} =
518 $facets->[$k]->{'label_value'};
519 $facets_info->{ $facets->[$k]
520 ->{'link_value'} }->{'expanded'} =
521 $facets->[$k]->{'expanded'};
527 $results_hashref->{ $servers[ $i - 1 ] } = $results_hash;
530 # warn "connection ", $i-1, ": $size hits";
531 # warn $results[$i-1]->record(0)->render() if $size > 0;
534 if ( $servers[ $i - 1 ] =~ /biblioserver/ ) {
536 sort { $facets_counter->{$b} <=> $facets_counter->{$a} }
537 keys %$facets_counter )
540 my $number_of_facets;
541 my @this_facets_array;
544 $facets_counter->{$link_value}
545 ->{$b} <=> $facets_counter->{$link_value}->{$a}
546 } keys %{ $facets_counter->{$link_value} }
550 if ( ( $number_of_facets < 6 )
551 || ( $expanded_facet eq $link_value )
552 || ( $facets_info->{$link_value}->{'expanded'} ) )
555 # Sanitize the link value ), ( will cause errors with CCL,
556 my $facet_link_value = $one_facet;
557 $facet_link_value =~ s/(\(|\))/ /g;
559 # fix the length that will display in the label,
560 my $facet_label_value = $one_facet;
562 substr( $one_facet, 0, 20 ) . "..."
563 unless length($facet_label_value) <= 20;
565 # if it's a branch, label by the name, not the code,
566 if ( $link_value =~ /branch/ ) {
568 $branches->{$one_facet}->{'branchname'};
571 # but we're down with the whole label being in the link's title.
572 my $facet_title_value = $one_facet;
574 push @this_facets_array,
578 $facets_counter->{$link_value}
580 facet_label_value => $facet_label_value,
581 facet_title_value => $facet_title_value,
582 facet_link_value => $facet_link_value,
583 type_link_value => $link_value,
589 # handle expanded option
590 unless ( $facets_info->{$link_value}->{'expanded'} ) {
592 if ( ( $number_of_facets > 6 )
593 && ( $expanded_facet ne $link_value ) );
598 type_link_value => $link_value,
599 type_id => $link_value . "_id",
601 $facets_info->{$link_value}->{'label_value'},
602 facets => \@this_facets_array,
603 expandable => $expandable,
604 expand => $link_value,
611 return ( undef, $results_hashref, \@facets_loop );
614 use C4::Search::PazPar2;
619 $koha_query, $simple_query, $sort_by_ref, $servers_ref,
620 $results_per_page, $offset, $expanded_facet, $branches,
624 my $paz = C4::Search::PazPar2->new('http://localhost:10006/search.pz2');
627 $paz->search($simple_query);
631 my $results_hashref = {};
632 my $stats = XMLin($paz->stat);
633 $results_hashref->{'biblioserver'}->{'hits'} = $stats->{'hits'};
634 my $results = XMLin($paz->show($offset, $results_per_page), forcearray => 1);
635 #die Dumper($results);
636 HIT: foreach my $hit (@{ $results->{'hit'} }) {
638 my $recid = $hit->{recid}->[0];
639 my $work_title = $hit->{'md-work-title'}->[0];
640 #if ($recid =~ /[\200-\377]/) {
641 if ($recid =~ /sodot/) {
643 #probably do not want non-ASCII in record ID
647 if (exists $hit->{count}) {
648 $count = $hit->{count}->[0];
651 for (my $i = 0; $i < $count; $i++) {
652 warn "look for $recid offset = $i";
653 my $rec = $paz->record($recid, $i);
654 warn "got record $i";
655 push @{ $results_hashref->{'biblioserver'}->{$work_title}->{'RECORDS'} }, $paz->record($recid, $i);
660 # pass through facets
661 my $termlist_xml = $paz->termlist('author,subject');
662 my $terms = XMLin($termlist_xml, forcearray => 1);
663 my @facets_loop = ();
664 #die Dumper($results);
665 # foreach my $list (sort keys %{ $terms->{'list'} }) {
667 # foreach my $facet (sort @{ $terms->{'list'}->{$list}->{'term'} } ) {
669 # facet_label_value => $facet->{'name'}->[0],
672 # push @facets_loop, ( {
673 # type_label => $list,
674 # facets => \@facets,
678 return ( undef, $results_hashref, \@facets_loop );
682 sub _remove_stopwords {
683 my ( $operand, $index ) = @_;
684 my @stopwords_removed;
686 # phrase and exact-qualified indexes shouldn't have stopwords removed
687 if ( $index !~ m/phr|ext/ ) {
689 # remove stopwords from operand : parse all stopwords & remove them (case insensitive)
690 # we use IsAlpha unicode definition, to deal correctly with diacritics.
691 # otherwise, a French word like "leçon" woudl be split into "le" "çon", "le"
692 # is a stopword, we'd get "çon" and wouldn't find anything...
693 foreach ( keys %{ C4::Context->stopwords } ) {
694 next if ( $_ =~ /(and|or|not)/ ); # don't remove operators
696 /(\P{IsAlpha}$_\P{IsAlpha}|^$_\P{IsAlpha}|\P{IsAlpha}$_$)/ )
698 $operand =~ s/\P{IsAlpha}$_\P{IsAlpha}/ /gi;
699 $operand =~ s/^$_\P{IsAlpha}/ /gi;
700 $operand =~ s/\P{IsAlpha}$_$/ /gi;
701 push @stopwords_removed, $_;
705 return ( $operand, \@stopwords_removed );
709 sub _detect_truncation {
710 my ( $operand, $index ) = @_;
711 my ( @nontruncated, @righttruncated, @lefttruncated, @rightlefttruncated,
714 my @wordlist = split( /\s/, $operand );
715 foreach my $word (@wordlist) {
716 if ( $word =~ s/^\*([^\*]+)\*$/$1/ ) {
717 push @rightlefttruncated, $word;
719 elsif ( $word =~ s/^\*([^\*]+)$/$1/ ) {
720 push @lefttruncated, $word;
722 elsif ( $word =~ s/^([^\*]+)\*$/$1/ ) {
723 push @righttruncated, $word;
725 elsif ( index( $word, "*" ) < 0 ) {
726 push @nontruncated, $word;
729 push @regexpr, $word;
733 \@nontruncated, \@righttruncated, \@lefttruncated,
734 \@rightlefttruncated, \@regexpr
739 sub _build_stemmed_operand {
743 # FIXME: the locale should be set based on the user's language and/or search choice
744 my $stemmer = Lingua::Stem->new( -locale => 'EN-US' );
746 # FIXME: these should be stored in the db so the librarian can modify the behavior
747 $stemmer->add_exceptions(
754 my @words = split( / /, $operand );
755 my $stems = $stemmer->stem(@words);
756 for my $stem (@$stems) {
757 $stemmed_operand .= "$stem";
758 $stemmed_operand .= "?"
759 unless ( $stem =~ /(and$|or$|not$)/ ) || ( length($stem) < 3 );
760 $stemmed_operand .= " ";
762 warn "STEMMED OPERAND: $stemmed_operand" if $DEBUG;
763 return $stemmed_operand;
767 sub _build_weighted_query {
769 # FIELD WEIGHTING - This is largely experimental stuff. What I'm committing works
770 # pretty well but could work much better if we had a smarter query parser
771 my ( $operand, $stemmed_operand, $index ) = @_;
772 my $stemming = C4::Context->preference("QueryStemming") || 0;
773 my $weight_fields = C4::Context->preference("QueryWeightFields") || 0;
774 my $fuzzy_enabled = C4::Context->preference("QueryFuzzy") || 0;
776 my $weighted_query .= "(rk=("; # Specifies that we're applying rank
778 # Keyword, or, no index specified
779 if ( ( $index eq 'kw' ) || ( !$index ) ) {
781 "Title-cover,ext,r1=\"$operand\""; # exact title-cover
782 $weighted_query .= " or ti,ext,r2=\"$operand\""; # exact title
783 $weighted_query .= " or ti,phr,r3=\"$operand\""; # phrase title
784 #$weighted_query .= " or any,ext,r4=$operand"; # exact any
785 #$weighted_query .=" or kw,wrdl,r5=\"$operand\""; # word list any
786 $weighted_query .= " or wrdl,fuzzy,r8=\"$operand\""
787 if $fuzzy_enabled; # add fuzzy, word list
788 $weighted_query .= " or wrdl,right-Truncation,r9=\"$stemmed_operand\""
789 if ( $stemming and $stemmed_operand )
790 ; # add stemming, right truncation
791 $weighted_query .= " or wrdl,r9=\"$operand\"";
793 # embedded sorting: 0 a-z; 1 z-a
794 # $weighted_query .= ") or (sort1,aut=1";
797 # Barcode searches should skip this process
798 elsif ( $index eq 'bc' ) {
799 $weighted_query .= "bc=\"$operand\"";
802 # Authority-number searches should skip this process
803 elsif ( $index eq 'an' ) {
804 $weighted_query .= "an=\"$operand\"";
807 # If the index already has more than one qualifier, wrap the operand
808 # in quotes and pass it back (assumption is that the user knows what they
809 # are doing and won't appreciate us mucking up their query
810 elsif ( $index =~ ',' ) {
811 $weighted_query .= " $index=\"$operand\"";
814 #TODO: build better cases based on specific search indexes
816 $weighted_query .= " $index,ext,r1=\"$operand\""; # exact index
817 #$weighted_query .= " or (title-sort-az=0 or $index,startswithnt,st-word,r3=$operand #)";
818 $weighted_query .= " or $index,phr,r3=\"$operand\""; # phrase index
820 " or $index,rt,wrdl,r3=\"$operand\""; # word list index
823 $weighted_query .= "))"; # close rank specification
824 return $weighted_query;
830 $simple_query, $query_cgi,
832 $limit_cgi, $limit_desc,
833 $stopwords_removed, $query_type ) = getRecords ( $operators, $operands, $indexes, $limits, $sort_by, $scan);
835 Build queries and limits in CCL, CGI, Human,
836 handle truncation, stemming, field weighting, stopwords, fuzziness, etc.
838 See verbose embedded documentation.
844 my ( $operators, $operands, $indexes, $limits, $sort_by, $scan ) = @_;
846 warn "---------" if $DEBUG;
847 warn "Enter buildQuery" if $DEBUG;
848 warn "---------" if $DEBUG;
851 my @operators = @$operators if $operators;
852 my @indexes = @$indexes if $indexes;
853 my @operands = @$operands if $operands;
854 my @limits = @$limits if $limits;
855 my @sort_by = @$sort_by if $sort_by;
857 my $stemming = C4::Context->preference("QueryStemming") || 0;
858 my $auto_truncation = C4::Context->preference("QueryAutoTruncate") || 0;
859 my $weight_fields = C4::Context->preference("QueryWeightFields") || 0;
860 my $fuzzy_enabled = C4::Context->preference("QueryFuzzy") || 0;
861 my $remove_stopwords = C4::Context->preference("QueryRemoveStopwords") || 0;
863 # no stemming/weight/fuzzy in NoZebra
864 if ( C4::Context->preference("NoZebra") ) {
870 my $query = $operands[0];
871 my $simple_query = $operands[0];
873 # initialize the variables we're passing back
882 my $stopwords_removed; # flag to determine if stopwords have been removed
884 # for handling ccl, cql, pqf queries in diagnostic mode, skip the rest of the steps
886 if ( $query =~ /^ccl=/ ) {
887 return ( undef, $', $', $', $', '', '', '', '', 'ccl' );
889 if ( $query =~ /^cql=/ ) {
890 return ( undef, $', $', $', $', '', '', '', '', 'cql' );
892 if ( $query =~ /^pqf=/ ) {
893 return ( undef, $', $', $', $', '', '', '', '', 'pqf' );
896 # pass nested queries directly
897 # FIXME: need better handling of some of these variables in this case
898 if ( $query =~ /(\(|\))/ ) {
900 undef, $query, $simple_query, $query_cgi,
901 $query, $limit, $limit_cgi, $limit_desc,
902 $stopwords_removed, 'ccl'
906 # Form-based queries are non-nested and fixed depth, so we can easily modify the incoming
907 # query operands and indexes and add stemming, truncation, field weighting, etc.
908 # Once we do so, we'll end up with a value in $query, just like if we had an
909 # incoming $query from the user
912 ; # clear it out so we can populate properly with field-weighted, stemmed, etc. query
914 ; # a flag used to keep track if there was a previous query
915 # if there was, we can apply the current operator
917 for ( my $i = 0 ; $i <= @operands ; $i++ ) {
919 # COMBINE OPERANDS, INDEXES AND OPERATORS
920 if ( $operands[$i] ) {
922 # A flag to determine whether or not to add the index to the query
925 # If the user is sophisticated enough to specify an index, turn off field weighting, stemming, and stopword handling
926 if ( $operands[$i] =~ /(:|=)/ || $scan ) {
929 $remove_stopwords = 0;
931 my $operand = $operands[$i];
932 my $index = $indexes[$i];
934 # Add index-specific attributes
935 # Date of Publication
936 if ( $index eq 'yr' ) {
937 $index .= ",st-numeric";
940 $stemming, $auto_truncation,
941 $weight_fields, $fuzzy_enabled,
943 ) = ( 0, 0, 0, 0, 0 );
946 # Date of Acquisition
947 elsif ( $index eq 'acqdate' ) {
948 $index .= ",st-date-normalized";
951 $stemming, $auto_truncation,
952 $weight_fields, $fuzzy_enabled,
954 ) = ( 0, 0, 0, 0, 0 );
957 # Set default structure attribute (word list)
959 unless ( !$index || $index =~ /(st-|phr|ext|wrdl)/ ) {
960 $struct_attr = ",wrdl";
963 # Some helpful index variants
964 my $index_plus = $index . $struct_attr . ":" if $index;
965 my $index_plus_comma = $index . $struct_attr . "," if $index;
968 if ($remove_stopwords) {
969 ( $operand, $stopwords_removed ) =
970 _remove_stopwords( $operand, $index );
971 warn "OPERAND w/out STOPWORDS: >$operand<" if $DEBUG;
972 warn "REMOVED STOPWORDS: @$stopwords_removed"
973 if ( $stopwords_removed && $DEBUG );
977 my ( $nontruncated, $righttruncated, $lefttruncated,
978 $rightlefttruncated, $regexpr );
979 my $truncated_operand;
981 $nontruncated, $righttruncated, $lefttruncated,
982 $rightlefttruncated, $regexpr
983 ) = _detect_truncation( $operand, $index );
985 "TRUNCATION: NON:>@$nontruncated< RIGHT:>@$righttruncated< LEFT:>@$lefttruncated< RIGHTLEFT:>@$rightlefttruncated< REGEX:>@$regexpr<"
990 scalar(@$righttruncated) + scalar(@$lefttruncated) +
991 scalar(@$rightlefttruncated) > 0 )
994 # Don't field weight or add the index to the query, we do it here
996 undef $weight_fields;
997 my $previous_truncation_operand;
998 if ( scalar(@$nontruncated) > 0 ) {
999 $truncated_operand .= "$index_plus @$nontruncated ";
1000 $previous_truncation_operand = 1;
1002 if ( scalar(@$righttruncated) > 0 ) {
1003 $truncated_operand .= "and "
1004 if $previous_truncation_operand;
1005 $truncated_operand .=
1006 "$index_plus_comma" . "rtrn:@$righttruncated ";
1007 $previous_truncation_operand = 1;
1009 if ( scalar(@$lefttruncated) > 0 ) {
1010 $truncated_operand .= "and "
1011 if $previous_truncation_operand;
1012 $truncated_operand .=
1013 "$index_plus_comma" . "ltrn:@$lefttruncated ";
1014 $previous_truncation_operand = 1;
1016 if ( scalar(@$rightlefttruncated) > 0 ) {
1017 $truncated_operand .= "and "
1018 if $previous_truncation_operand;
1019 $truncated_operand .=
1020 "$index_plus_comma" . "rltrn:@$rightlefttruncated ";
1021 $previous_truncation_operand = 1;
1024 $operand = $truncated_operand if $truncated_operand;
1025 warn "TRUNCATED OPERAND: >$truncated_operand<" if $DEBUG;
1028 my $stemmed_operand;
1029 $stemmed_operand = _build_stemmed_operand($operand)
1031 warn "STEMMED OPERAND: >$stemmed_operand<" if $DEBUG;
1033 # Handle Field Weighting
1034 my $weighted_operand;
1036 _build_weighted_query( $operand, $stemmed_operand, $index )
1038 warn "FIELD WEIGHTED OPERAND: >$weighted_operand<" if $DEBUG;
1039 $operand = $weighted_operand if $weight_fields;
1040 $indexes_set = 1 if $weight_fields;
1042 # If there's a previous operand, we need to add an operator
1043 if ($previous_operand) {
1045 # User-specified operator
1046 if ( $operators[ $i - 1 ] ) {
1047 $query .= " $operators[$i-1] ";
1048 $query .= " $index_plus " unless $indexes_set;
1049 $query .= " $operand";
1050 $query_cgi .= "&op=$operators[$i-1]";
1051 $query_cgi .= "&idx=$index" if $index;
1052 $query_cgi .= "&q=$operands[$i]" if $operands[$i];
1054 " $operators[$i-1] $index_plus $operands[$i]";
1057 # Default operator is and
1060 $query .= "$index_plus " unless $indexes_set;
1061 $query .= "$operand";
1062 $query_cgi .= "&op=and&idx=$index" if $index;
1063 $query_cgi .= "&q=$operands[$i]" if $operands[$i];
1064 $query_desc .= " and $index_plus $operands[$i]";
1068 # There isn't a pervious operand, don't need an operator
1071 # Field-weighted queries already have indexes set
1072 $query .= " $index_plus " unless $indexes_set;
1074 $query_desc .= " $index_plus $operands[$i]";
1075 $query_cgi .= "&idx=$index" if $index;
1076 $query_cgi .= "&q=$operands[$i]" if $operands[$i];
1077 $previous_operand = 1;
1082 warn "QUERY BEFORE LIMITS: >$query<" if $DEBUG;
1085 my $group_OR_limits;
1086 my $availability_limit;
1087 foreach my $this_limit (@limits) {
1088 if ( $this_limit =~ /available/ ) {
1090 # 'available' is defined as (items.onloan is NULL) and (items.itemlost = 0)
1092 # all records not indexed in the onloan register (zebra) and all records with a value of lost equal to 0
1093 $availability_limit .=
1094 "( ( allrecords,AlwaysMatches='' not onloan,AlwaysMatches='') and (lost,st-numeric=0) )"; #or ( allrecords,AlwaysMatches='' not lost,AlwaysMatches='')) )";
1095 $limit_cgi .= "&limit=available";
1099 # group_OR_limits, prefixed by mc-
1100 # OR every member of the group
1101 elsif ( $this_limit =~ /mc/ ) {
1102 $group_OR_limits .= " or " if $group_OR_limits;
1103 $limit_desc .= " or " if $group_OR_limits;
1104 $group_OR_limits .= "$this_limit";
1105 $limit_cgi .= "&limit=$this_limit";
1106 $limit_desc .= " $this_limit";
1109 # Regular old limits
1111 $limit .= " and " if $limit || $query;
1112 $limit .= "$this_limit";
1113 $limit_cgi .= "&limit=$this_limit";
1114 $limit_desc .= " $this_limit";
1117 if ($group_OR_limits) {
1118 $limit .= " and " if ( $query || $limit );
1119 $limit .= "($group_OR_limits)";
1121 if ($availability_limit) {
1122 $limit .= " and " if ( $query || $limit );
1123 $limit .= "($availability_limit)";
1126 # Normalize the query and limit strings
1129 for ( $query, $query_desc, $limit, $limit_desc ) {
1130 $_ =~ s/ / /g; # remove extra spaces
1131 $_ =~ s/^ //g; # remove any beginning spaces
1132 $_ =~ s/ $//g; # remove any ending spaces
1133 $_ =~ s/==/=/g; # remove double == from query
1135 $query_cgi =~ s/^&//; # remove unnecessary & from beginning of the query cgi
1137 for ($query_cgi,$simple_query) {
1140 # append the limit to the query
1141 $query .= " " . $limit;
1145 warn "QUERY:" . $query;
1146 warn "QUERY CGI:" . $query_cgi;
1147 warn "QUERY DESC:" . $query_desc;
1148 warn "LIMIT:" . $limit;
1149 warn "LIMIT CGI:" . $limit_cgi;
1150 warn "LIMIT DESC:" . $limit_desc;
1152 warn "Leave buildQuery";
1156 undef, $query, $simple_query, $query_cgi,
1157 $query_desc, $limit, $limit_cgi, $limit_desc,
1158 $stopwords_removed, $query_type
1162 =head2 searchResults
1164 Format results in a form suitable for passing to the template
1168 # IMO this subroutine is pretty messy still -- it's responsible for
1169 # building the HTML output for the template
1171 my ( $searchdesc, $hits, $results_per_page, $offset, @marcresults ) = @_;
1172 my $dbh = C4::Context->dbh;
1177 # add search-term highlighting via <span>s on the search terms
1178 my $span_terms_hashref;
1179 for my $span_term ( split( / /, $searchdesc ) ) {
1180 $span_term =~ s/(.*=|\)|\(|\+|\.|\*)//g;
1181 $span_terms_hashref->{$span_term}++;
1184 #Build branchnames hash
1186 #get branch information.....
1189 $dbh->prepare("SELECT branchcode,branchname FROM branches")
1190 ; # FIXME : use C4::Koha::GetBranches
1192 while ( my $bdata = $bsth->fetchrow_hashref ) {
1193 $branches{ $bdata->{'branchcode'} } = $bdata->{'branchname'};
1198 "SELECT authorised_value,lib FROM authorised_values WHERE category = 'LOC'"
1201 while ( my $ldata = $lsch->fetchrow_hashref ) {
1202 $locations{ $ldata->{'authorised_value'} } = $ldata->{'lib'};
1205 #Build itemtype hash
1206 #find itemtype & itemtype image
1210 "SELECT itemtype,description,imageurl,summary,notforloan FROM itemtypes"
1213 while ( my $bdata = $bsth->fetchrow_hashref ) {
1214 $itemtypes{ $bdata->{'itemtype'} }->{description} =
1215 $bdata->{'description'};
1216 $itemtypes{ $bdata->{'itemtype'} }->{imageurl} = $bdata->{'imageurl'};
1217 $itemtypes{ $bdata->{'itemtype'} }->{summary} = $bdata->{'summary'};
1218 $itemtypes{ $bdata->{'itemtype'} }->{notforloan} =
1219 $bdata->{'notforloan'};
1222 #search item field code
1225 "SELECT tagfield FROM marc_subfield_structure WHERE kohafield LIKE 'items.itemnumber'"
1228 my ($itemtag) = $sth->fetchrow;
1230 # get notforloan authorised value list
1233 "SELECT authorised_value FROM `marc_subfield_structure` WHERE kohafield = 'items.notforloan' AND frameworkcode=''"
1236 my ($notforloan_authorised_value) = $sth->fetchrow;
1238 ## find column names of items related to MARC
1239 my $sth2 = $dbh->prepare("SHOW COLUMNS FROM items");
1241 my %subfieldstosearch;
1242 while ( ( my $column ) = $sth2->fetchrow ) {
1243 my ( $tagfield, $tagsubfield ) =
1244 &GetMarcFromKohaField( "items." . $column, "" );
1245 $subfieldstosearch{$column} = $tagsubfield;
1248 # handle which records to actually retrieve
1250 if ( $hits && $offset + $results_per_page <= $hits ) {
1251 $times = $offset + $results_per_page;
1257 # loop through all of the records we've retrieved
1258 for ( my $i = $offset ; $i <= $times - 1 ; $i++ ) {
1260 $marcrecord = MARC::File::USMARC::decode( $marcresults[$i] );
1261 my $oldbiblio = TransformMarcToKoha( $dbh, $marcrecord, '' );
1262 $oldbiblio->{result_number} = $i + 1;
1264 # add imageurl to itemtype if there is one
1265 if ( $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} =~ /^http:/ ) {
1266 $oldbiblio->{imageurl} =
1267 $itemtypes{ $oldbiblio->{itemtype} }->{imageurl};
1268 $oldbiblio->{description} =
1269 $itemtypes{ $oldbiblio->{itemtype} }->{description};
1272 $oldbiblio->{imageurl} =
1273 getitemtypeimagesrc() . "/"
1274 . $itemtypes{ $oldbiblio->{itemtype} }->{imageurl}
1275 if ( $itemtypes{ $oldbiblio->{itemtype} }->{imageurl} );
1276 $oldbiblio->{description} =
1277 $itemtypes{ $oldbiblio->{itemtype} }->{description};
1280 # Build summary if there is one (the summary is defined in the itemtypes table)
1281 # FIXME: is this used anywhere, I think it can be commented out? -- JF
1282 if ( $itemtypes{ $oldbiblio->{itemtype} }->{summary} ) {
1283 my $summary = $itemtypes{ $oldbiblio->{itemtype} }->{summary};
1284 my @fields = $marcrecord->fields();
1285 foreach my $field (@fields) {
1286 my $tag = $field->tag();
1287 my $tagvalue = $field->as_string();
1289 s/\[(.?.?.?.?)$tag\*(.*?)]/$1$tagvalue$2\[$1$tag$2]/g;
1290 unless ( $tag < 10 ) {
1291 my @subf = $field->subfields;
1292 for my $i ( 0 .. $#subf ) {
1293 my $subfieldcode = $subf[$i][0];
1294 my $subfieldvalue = $subf[$i][1];
1295 my $tagsubf = $tag . $subfieldcode;
1297 s/\[(.?.?.?.?)$tagsubf(.*?)]/$1$subfieldvalue$2\[$1$tagsubf$2]/g;
1302 $summary =~ s/\[(.*?)]//g;
1303 $summary =~ s/\n/<br>/g;
1304 $oldbiblio->{summary} = $summary;
1307 # Add search-term highlighting to the whole record where they match using <span>s
1308 if (C4::Context->preference("OpacHighlightedWords")){
1309 my $searchhighlightblob;
1310 for my $highlight_field ( $marcrecord->fields ) {
1312 # FIXME: need to skip title, subtitle, author, etc., as they are handled below
1313 next if $highlight_field->tag() =~ /(^00)/; # skip fixed fields
1314 for my $subfield ($highlight_field->subfields()) {
1316 next if $subfield->[0] eq '9';
1317 my $field = $subfield->[1];
1318 for my $term ( keys %$span_terms_hashref ) {
1319 if ( ( $field =~ /$term/i ) && (( length($term) > 3 ) || ($field =~ / $term /i)) ) {
1320 $field =~ s/$term/<span class=\"term\">$&<\/span>/gi;
1324 $searchhighlightblob .= $field . " ... " if $match;
1328 $searchhighlightblob = ' ... '.$searchhighlightblob if $searchhighlightblob;
1329 $oldbiblio->{'searchhighlightblob'} = $searchhighlightblob;
1331 # save an author with no <span> tag, for the <a href=search.pl?q=<!--tmpl_var name="author"-->> link
1332 $oldbiblio->{'author_nospan'} = $oldbiblio->{'author'};
1334 # Add search-term highlighting to the title, subtitle, etc. fields
1335 for my $term ( keys %$span_terms_hashref ) {
1336 my $old_term = $term;
1337 if ( length($term) > 3 ) {
1338 $term =~ s/(.*=|\)|\(|\+|\.|\?|\[|\]|\\|\*)//g;
1339 $oldbiblio->{'title'} =~
1340 s/$term/<span class=\"term\">$&<\/span>/gi;
1341 $oldbiblio->{'subtitle'} =~
1342 s/$term/<span class=\"term\">$&<\/span>/gi;
1343 $oldbiblio->{'author'} =~
1344 s/$term/<span class=\"term\">$&<\/span>/gi;
1345 $oldbiblio->{'publishercode'} =~
1346 s/$term/<span class=\"term\">$&<\/span>/gi;
1347 $oldbiblio->{'place'} =~
1348 s/$term/<span class=\"term\">$&<\/span>/gi;
1349 $oldbiblio->{'pages'} =~
1350 s/$term/<span class=\"term\">$&<\/span>/gi;
1351 $oldbiblio->{'notes'} =~
1352 s/$term/<span class=\"term\">$&<\/span>/gi;
1353 $oldbiblio->{'size'} =~
1354 s/$term/<span class=\"term\">$&<\/span>/gi;
1359 # surely there's a better way to handle this
1361 $toggle = "#ffffcc";
1366 $oldbiblio->{'toggle'} = $toggle;
1368 # Pull out the items fields
1369 my @fields = $marcrecord->field($itemtag);
1371 # Setting item statuses for display
1372 my @available_items_loop;
1373 my @onloan_items_loop;
1374 my @other_items_loop;
1376 my $available_items;
1380 my $ordered_count = 0;
1381 my $available_count = 0;
1382 my $onloan_count = 0;
1383 my $longoverdue_count = 0;
1384 my $other_count = 0;
1385 my $wthdrawn_count = 0;
1386 my $itemlost_count = 0;
1387 my $itembinding_count = 0;
1388 my $itemdamaged_count = 0;
1389 my $can_place_holds = 0;
1390 my $items_count = scalar(@fields);
1393 ( C4::Context->preference('maxItemsinSearchResults') )
1394 ? C4::Context->preference('maxItemsinSearchResults') - 1
1397 # loop through every item
1398 foreach my $field (@fields) {
1402 # populate the items hash
1403 foreach my $code ( keys %subfieldstosearch ) {
1404 $item->{$code} = $field->subfield( $subfieldstosearch{$code} );
1407 # set item's branch name, use HomeOrHoldingBranch syspref first, fall back to the other one
1408 if ( $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} ) {
1409 $item->{'branchname'} = $branches{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} };
1412 elsif ( $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'holdingbranch':'homebranch'} ) {
1413 $item->{'branchname'} = $branches{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'holdingbranch':'homebranch'} };
1416 # For each grouping of items (onloan, available, unavailable), we build a key to store relevant info about that item
1417 if ( $item->{onloan} ) {
1419 $onloan_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{due_date} }->{due_date} = format_date( $item->{onloan} );
1420 $onloan_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{due_date} }->{count}++ if $item->{'homebranch'};
1421 $onloan_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{due_date} }->{branchname} = $item->{'branchname'};
1422 $onloan_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{due_date} }->{location} = $locations{ $item->{location} };
1423 $onloan_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{due_date} }->{itemcallnumber} = $item->{itemcallnumber};
1424 $onloan_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{due_date} }->{imageurl} = getitemtypeimagesrc() . "/" . $itemtypes{ $item->{itype} }->{imageurl};
1425 # if something's checked out and lost, mark it as 'long overdue'
1426 if ( $item->{itemlost} ) {
1427 $onloan_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{due_date} }->{longoverdue}++;
1428 $longoverdue_count++;
1431 # can place holds as long as this item isn't lost
1433 $can_place_holds = 1;
1437 # items not on loan, but still unavailable ( lost, withdrawn, damaged )
1441 if ( $item->{notforloan} == -1 ) {
1445 # item is withdrawn, lost or damaged
1446 if ( $item->{wthdrawn}
1447 || $item->{itemlost}
1449 || $item->{notforloan} )
1451 $wthdrawn_count++ if $item->{wthdrawn};
1452 $itemlost_count++ if $item->{itemlost};
1453 $itemdamaged_count++ if $item->{damaged};
1454 $item->{status} = $item->{wthdrawn} . "-" . $item->{itemlost} . "-" . $item->{damaged} . "-" . $item->{notforloan};
1457 $other_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{status} }->{wthdrawn} = $item->{wthdrawn};
1458 $other_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{status} }->{itemlost} = $item->{itemlost};
1459 $other_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{status} }->{damaged} = $item->{damaged};
1460 $other_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{status} }->{notforloan} = GetAuthorisedValueDesc( '', '', $item->{notforloan}, '', '', $notforloan_authorised_value ) if $notforloan_authorised_value;
1461 $other_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{status} }->{count}++ if $item->{'homebranch'};
1462 $other_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{status} }->{branchname} = $item->{'branchname'};
1463 $other_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{status} }->{location} = $locations{ $item->{location} };
1464 $other_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{status} }->{itemcallnumber} = $item->{itemcallnumber};
1465 $other_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} . $item->{status} }->{imageurl} = getitemtypeimagesrc() . "/" . $itemtypes{ $item->{itype} }->{imageurl};
1470 $can_place_holds = 1;
1472 $available_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} }->{count}++ if $item->{'homebranch'};
1473 $available_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} }->{branchname} = $item->{'branchname'};
1474 $available_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} }->{location} = $locations{ $item->{location} };
1475 $available_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} }->{itemcallnumber} = $item->{itemcallnumber};
1476 $available_items->{ $item->{C4::Context->preference('HomeOrHoldingBranch') eq 'homebranch'?'homebranch':'holdingbranch'} . '--' . $item->{location} . $item->{'itype'} . $item->{'itemcallnumber'} }->{imageurl} = getitemtypeimagesrc() . "/" . $itemtypes{ $item->{itype} }->{imageurl};
1479 } # notforloan, item level and biblioitem level
1480 my ( $availableitemscount, $onloanitemscount, $otheritemscount );
1482 ( C4::Context->preference('maxItemsinSearchResults') )
1483 ? C4::Context->preference('maxItemsinSearchResults') - 1
1485 for my $key ( sort keys %$onloan_items ) {
1486 $onloanitemscount++;
1487 push @onloan_items_loop, $onloan_items->{$key}
1488 unless $onloanitemscount > $maxitems;
1490 for my $key ( sort keys %$other_items ) {
1492 push @other_items_loop, $other_items->{$key}
1493 unless $otheritemscount > $maxitems;
1495 for my $key ( sort keys %$available_items ) {
1496 $availableitemscount++;
1497 push @available_items_loop, $available_items->{$key}
1498 unless $availableitemscount > $maxitems;
1501 # last check for norequest : if itemtype is notforloan, it can't be reserved either, whatever the items
1502 $can_place_holds = 0
1503 if $itemtypes{ $oldbiblio->{itemtype} }->{notforloan};
1504 $oldbiblio->{norequests} = 1 unless $can_place_holds;
1505 $oldbiblio->{itemsplural} = 1 if $items_count > 1;
1506 $oldbiblio->{items_count} = $items_count;
1507 $oldbiblio->{available_items_loop} = \@available_items_loop;
1508 $oldbiblio->{onloan_items_loop} = \@onloan_items_loop;
1509 $oldbiblio->{other_items_loop} = \@other_items_loop;
1510 $oldbiblio->{availablecount} = $available_count;
1511 $oldbiblio->{availableplural} = 1 if $available_count > 1;
1512 $oldbiblio->{onloancount} = $onloan_count;
1513 $oldbiblio->{onloanplural} = 1 if $onloan_count > 1;
1514 $oldbiblio->{othercount} = $other_count;
1515 $oldbiblio->{otherplural} = 1 if $other_count > 1;
1516 $oldbiblio->{wthdrawncount} = $wthdrawn_count;
1517 $oldbiblio->{itemlostcount} = $itemlost_count;
1518 $oldbiblio->{damagedcount} = $itemdamaged_count;
1519 $oldbiblio->{orderedcount} = $ordered_count;
1520 $oldbiblio->{isbn} =~
1521 s/-//g; # deleting - in isbn to enable amazon content
1522 push( @newresults, $oldbiblio );
1527 #----------------------------------------------------------------------
1529 # Non-Zebra GetRecords#
1530 #----------------------------------------------------------------------
1534 NZgetRecords has the same API as zera getRecords, even if some parameters are not managed
1540 $query, $simple_query, $sort_by_ref, $servers_ref,
1541 $results_per_page, $offset, $expanded_facet, $branches,
1544 warn "query =$query" if $DEBUG;
1545 my $result = NZanalyse($query);
1546 warn "results =$result" if $DEBUG;
1548 NZorder( $result, @$sort_by_ref[0], $results_per_page, $offset ),
1554 NZanalyse : get a CQL string as parameter, and returns a list of biblionumber;title,biblionumber;title,...
1555 the list is built from an inverted index in the nozebra SQL table
1556 note that title is here only for convenience : the sorting will be very fast when requested on title
1557 if the sorting is requested on something else, we will have to reread all results, and that may be longer.
1562 my ( $string, $server ) = @_;
1563 # warn "---------" if $DEBUG;
1564 warn " NZanalyse" if $DEBUG;
1565 # warn "---------" if $DEBUG;
1567 # $server contains biblioserver or authorities, depending on what we search on.
1568 #warn "querying : $string on $server";
1569 $server = 'biblioserver' unless $server;
1571 # if we have a ", replace the content to discard temporarily any and/or/not inside
1573 if ( $string =~ /"/ ) {
1574 $string =~ s/"(.*?)"/__X__/;
1576 warn "commacontent : $commacontent" if $DEBUG;
1579 # split the query string in 3 parts : X AND Y means : $left="X", $operand="AND" and $right="Y"
1580 # then, call again NZanalyse with $left and $right
1581 # (recursive until we find a leaf (=> something without and/or/not)
1582 # delete repeated operator... Would then go in infinite loop
1583 while ( $string =~ s/( and| or| not| AND| OR| NOT)\1/$1/g ) {
1586 #process parenthesis before.
1587 if ( $string =~ /^\s*\((.*)\)(( and | or | not | AND | OR | NOT )(.*))?/ ) {
1590 my $operator = lc($3); # FIXME: and/or/not are operators, not operands
1592 "dealing w/parenthesis before recursive sub call. left :$left operator:$operator right:$right"
1594 my $leftresult = NZanalyse( $left, $server );
1596 my $rightresult = NZanalyse( $right, $server );
1598 # OK, we have the results for right and left part of the query
1599 # depending of operand, intersect, union or exclude both lists
1600 # to get a result list
1601 if ( $operator eq ' and ' ) {
1602 return NZoperatorAND($leftresult,$rightresult);
1604 elsif ( $operator eq ' or ' ) {
1606 # just merge the 2 strings
1607 return $leftresult . $rightresult;
1609 elsif ( $operator eq ' not ' ) {
1610 return NZoperatorNOT($leftresult,$rightresult);
1614 # this error is impossible, because of the regexp that isolate the operand, but just in case...
1618 warn "string :" . $string if $DEBUG;
1619 $string =~ /(.*?)( and | or | not | AND | OR | NOT )(.*)/;
1622 my $operator = lc($2); # FIXME: and/or/not are operators, not operands
1623 warn "no parenthesis. left : $left operator: $operator right: $right"
1626 # it's not a leaf, we have a and/or/not
1629 # reintroduce comma content if needed
1630 $right =~ s/__X__/"$commacontent"/ if $commacontent;
1631 $left =~ s/__X__/"$commacontent"/ if $commacontent;
1632 warn "node : $left / $operator / $right\n" if $DEBUG;
1633 my $leftresult = NZanalyse( $left, $server );
1634 my $rightresult = NZanalyse( $right, $server );
1635 warn " leftresult : $leftresult" if $DEBUG;
1636 warn " rightresult : $rightresult" if $DEBUG;
1637 # OK, we have the results for right and left part of the query
1638 # depending of operand, intersect, union or exclude both lists
1639 # to get a result list
1640 if ( $operator eq ' and ' ) {
1642 return NZoperatorAND($leftresult,$rightresult);
1644 elsif ( $operator eq ' or ' ) {
1646 # just merge the 2 strings
1647 return $leftresult . $rightresult;
1649 elsif ( $operator eq ' not ' ) {
1650 return NZoperatorNOT($leftresult,$rightresult);
1654 # this error is impossible, because of the regexp that isolate the operand, but just in case...
1655 die "error : operand unknown : $operator for $string";
1658 # it's a leaf, do the real SQL query and return the result
1661 $string =~ s/__X__/"$commacontent"/ if $commacontent;
1662 $string =~ s/-|\.|\?|,|;|!|'|\(|\)|\[|\]|{|}|"|&|\+|\*|\// /g;
1663 warn "leaf:$string" if $DEBUG;
1665 # parse the string in in operator/operand/value again
1666 $string =~ /(.*)(>=|<=)(.*)/;
1670 # warn "handling leaf... left:$left operator:$operator right:$right"
1672 unless ($operator) {
1673 $string =~ /(.*)(>|<|=)(.*)/;
1678 # "handling unless (operator)... left:$left operator:$operator right:$right"
1683 # strip adv, zebra keywords, currently not handled in nozebra: wrdl, ext, phr...
1684 $left =~ s/[, ].*$//;
1686 # automatic replace for short operators
1687 $left = 'title' if $left =~ '^ti$';
1688 $left = 'author' if $left =~ '^au$';
1689 $left = 'publisher' if $left =~ '^pb$';
1690 $left = 'subject' if $left =~ '^su$';
1691 $left = 'koha-Auth-Number' if $left =~ '^an$';
1692 $left = 'keyword' if $left =~ '^kw$';
1693 warn "handling leaf... left:$left operator:$operator right:$right";
1694 if ( $operator && $left ne 'keyword' ) {
1696 #do a specific search
1697 my $dbh = C4::Context->dbh;
1698 $operator = 'LIKE' if $operator eq '=' and $right =~ /%/;
1701 "SELECT biblionumbers,value FROM nozebra WHERE server=? AND indexname=? AND value $operator ?"
1703 warn "$left / $operator / $right\n";
1705 # split each word, query the DB and build the biblionumbers result
1706 #sanitizing leftpart
1707 $left =~ s/^\s+|\s+$//;
1708 foreach ( split / /, $right ) {
1710 $_ =~ s/^\s+|\s+$//;
1712 warn "EXECUTE : $server, $left, $_";
1713 $sth->execute( $server, $left, $_ )
1714 or warn "execute failed: $!";
1715 while ( my ( $line, $value ) = $sth->fetchrow ) {
1717 # if we are dealing with a numeric value, use only numeric results (in case of >=, <=, > or <)
1718 # otherwise, fill the result
1719 $biblionumbers .= $line
1720 unless ( $right =~ /^\d+$/ && $value =~ /\D/ );
1721 warn "result : $value "
1722 . ( $right =~ /\d/ ) . "=="
1723 . ( $value =~ /\D/?$line:"" ); #= $line";
1726 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
1729 $results = NZoperatorAND($biblionumbers,$results);
1732 $results = $biblionumbers;
1738 #do a complete search (all indexes), if index='kw' do complete search too.
1739 my $dbh = C4::Context->dbh;
1742 "SELECT biblionumbers FROM nozebra WHERE server=? AND value LIKE ?"
1745 # split each word, query the DB and build the biblionumbers result
1746 foreach ( split / /, $string ) {
1747 next if C4::Context->stopwords->{ uc($_) }; # skip if stopword
1748 warn "search on all indexes on $_" if $DEBUG;
1751 $sth->execute( $server, $_ );
1752 while ( my $line = $sth->fetchrow ) {
1753 $biblionumbers .= $line;
1756 # do a AND with existing list if there is one, otherwise, use the biblionumbers list as 1st result list
1758 $results = NZoperatorAND($biblionumbers,$results);
1761 warn "NEW RES for $_ = $biblionumbers" if $DEBUG;
1762 $results = $biblionumbers;
1766 warn "return : $results for LEAF : $string" if $DEBUG;
1769 warn "---------" if $DEBUG;
1770 warn "Leave NZanalyse" if $DEBUG;
1771 warn "---------" if $DEBUG;
1775 my ($rightresult, $leftresult)=@_;
1777 my @leftresult = split /;/, $leftresult;
1778 warn " @leftresult / $rightresult \n" if $DEBUG;
1780 # my @rightresult = split /;/,$leftresult;
1783 # parse the left results, and if the biblionumber exist in the right result, save it in finalresult
1784 # the result is stored twice, to have the same weight for AND than OR.
1785 # example : TWO : 61,61,64,121 (two is twice in the biblio #61) / TOWER : 61,64,130
1786 # result : 61,61,61,61,64,64 for two AND tower : 61 has more weight than 64
1787 foreach (@leftresult) {
1790 ( $value, $countvalue ) = ( $1, $2 ) if ($value=~/(.*)-(\d+)$/);
1791 if ( $rightresult =~ /$value-(\d+);/ ) {
1792 $countvalue = ( $1 > $countvalue ? $countvalue : $1 );
1794 "$value-$countvalue;$value-$countvalue;";
1797 warn " $finalresult \n" if $DEBUG;
1798 return $finalresult;
1802 my ($rightresult, $leftresult)=@_;
1803 return $rightresult.$leftresult;
1807 my ($rightresult, $leftresult)=@_;
1809 my @leftresult = split /;/, $leftresult;
1811 # my @rightresult = split /;/,$leftresult;
1813 foreach (@leftresult) {
1815 $value=$1 if $value=~m/(.*)-\d+$/;
1816 unless ($rightresult =~ "$value-") {
1817 $finalresult .= "$_;";
1820 return $finalresult;
1825 $finalresult = NZorder($biblionumbers, $ordering,$results_per_page,$offset);
1832 my ( $biblionumbers, $ordering, $results_per_page, $offset ) = @_;
1833 warn "biblionumbers = $biblionumbers and ordering = $ordering\n" if $DEBUG;
1835 # order title asc by default
1836 # $ordering = '1=36 <i' unless $ordering;
1837 $results_per_page = 20 unless $results_per_page;
1838 $offset = 0 unless $offset;
1839 my $dbh = C4::Context->dbh;
1842 # order by POPULARITY
1844 if ( $ordering =~ /popularity/ ) {
1848 # popularity is not in MARC record, it's builded from a specific query
1850 $dbh->prepare("select sum(issues) from items where biblionumber=?");
1851 foreach ( split /;/, $biblionumbers ) {
1852 my ( $biblionumber, $title ) = split /,/, $_;
1853 $result{$biblionumber} = GetMarcBiblio($biblionumber);
1854 $sth->execute($biblionumber);
1855 my $popularity = $sth->fetchrow || 0;
1857 # hint : the key is popularity.title because we can have
1858 # many results with the same popularity. In this cas, sub-ordering is done by title
1859 # we also have biblionumber to avoid bug for 2 biblios with the same title & popularity
1860 # (un-frequent, I agree, but we won't forget anything that way ;-)
1861 $popularity{ sprintf( "%10d", $popularity ) . $title
1862 . $biblionumber } = $biblionumber;
1865 # sort the hash and return the same structure as GetRecords (Zebra querying)
1868 if ( $ordering eq 'popularity_dsc' ) { # sort popularity DESC
1869 foreach my $key ( sort { $b cmp $a } ( keys %popularity ) ) {
1870 $result_hash->{'RECORDS'}[ $numbers++ ] =
1871 $result{ $popularity{$key} }->as_usmarc();
1874 else { # sort popularity ASC
1875 foreach my $key ( sort ( keys %popularity ) ) {
1876 $result_hash->{'RECORDS'}[ $numbers++ ] =
1877 $result{ $popularity{$key} }->as_usmarc();
1880 my $finalresult = ();
1881 $result_hash->{'hits'} = $numbers;
1882 $finalresult->{'biblioserver'} = $result_hash;
1883 return $finalresult;
1889 elsif ( $ordering =~ /author/ ) {
1891 foreach ( split /;/, $biblionumbers ) {
1892 my ( $biblionumber, $title ) = split /,/, $_;
1893 my $record = GetMarcBiblio($biblionumber);
1895 if ( C4::Context->preference('marcflavour') eq 'UNIMARC' ) {
1896 $author = $record->subfield( '200', 'f' );
1897 $author = $record->subfield( '700', 'a' ) unless $author;
1900 $author = $record->subfield( '100', 'a' );
1903 # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1904 # and we don't want to get only 1 result for each of them !!!
1905 $result{ $author . $biblionumber } = $record;
1908 # sort the hash and return the same structure as GetRecords (Zebra querying)
1911 if ( $ordering eq 'author_za' ) { # sort by author desc
1912 foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
1913 $result_hash->{'RECORDS'}[ $numbers++ ] =
1914 $result{$key}->as_usmarc();
1917 else { # sort by author ASC
1918 foreach my $key ( sort ( keys %result ) ) {
1919 $result_hash->{'RECORDS'}[ $numbers++ ] =
1920 $result{$key}->as_usmarc();
1923 my $finalresult = ();
1924 $result_hash->{'hits'} = $numbers;
1925 $finalresult->{'biblioserver'} = $result_hash;
1926 return $finalresult;
1929 # ORDER BY callnumber
1932 elsif ( $ordering =~ /callnumber/ ) {
1934 foreach ( split /;/, $biblionumbers ) {
1935 my ( $biblionumber, $title ) = split /,/, $_;
1936 my $record = GetMarcBiblio($biblionumber);
1938 my ( $callnumber_tag, $callnumber_subfield ) =
1939 GetMarcFromKohaField( $dbh, 'items.itemcallnumber' );
1940 ( $callnumber_tag, $callnumber_subfield ) =
1941 GetMarcFromKohaField('biblioitems.callnumber')
1942 unless $callnumber_tag;
1943 if ( C4::Context->preference('marcflavour') eq 'UNIMARC' ) {
1944 $callnumber = $record->subfield( '200', 'f' );
1947 $callnumber = $record->subfield( '100', 'a' );
1950 # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1951 # and we don't want to get only 1 result for each of them !!!
1952 $result{ $callnumber . $biblionumber } = $record;
1955 # sort the hash and return the same structure as GetRecords (Zebra querying)
1958 if ( $ordering eq 'call_number_dsc' ) { # sort by title desc
1959 foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
1960 $result_hash->{'RECORDS'}[ $numbers++ ] =
1961 $result{$key}->as_usmarc();
1964 else { # sort by title ASC
1965 foreach my $key ( sort { $a cmp $b } ( keys %result ) ) {
1966 $result_hash->{'RECORDS'}[ $numbers++ ] =
1967 $result{$key}->as_usmarc();
1970 my $finalresult = ();
1971 $result_hash->{'hits'} = $numbers;
1972 $finalresult->{'biblioserver'} = $result_hash;
1973 return $finalresult;
1975 elsif ( $ordering =~ /pubdate/ ) { #pub year
1977 foreach ( split /;/, $biblionumbers ) {
1978 my ( $biblionumber, $title ) = split /,/, $_;
1979 my $record = GetMarcBiblio($biblionumber);
1980 my ( $publicationyear_tag, $publicationyear_subfield ) =
1981 GetMarcFromKohaField( 'biblioitems.publicationyear', '' );
1982 my $publicationyear =
1983 $record->subfield( $publicationyear_tag,
1984 $publicationyear_subfield );
1986 # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
1987 # and we don't want to get only 1 result for each of them !!!
1988 $result{ $publicationyear . $biblionumber } = $record;
1991 # sort the hash and return the same structure as GetRecords (Zebra querying)
1994 if ( $ordering eq 'pubdate_dsc' ) { # sort by pubyear desc
1995 foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
1996 $result_hash->{'RECORDS'}[ $numbers++ ] =
1997 $result{$key}->as_usmarc();
2000 else { # sort by pub year ASC
2001 foreach my $key ( sort ( keys %result ) ) {
2002 $result_hash->{'RECORDS'}[ $numbers++ ] =
2003 $result{$key}->as_usmarc();
2006 my $finalresult = ();
2007 $result_hash->{'hits'} = $numbers;
2008 $finalresult->{'biblioserver'} = $result_hash;
2009 return $finalresult;
2015 elsif ( $ordering =~ /title/ ) {
2017 # the title is in the biblionumbers string, so we just need to build a hash, sort it and return
2019 foreach ( split /;/, $biblionumbers ) {
2020 my ( $biblionumber, $title ) = split /,/, $_;
2022 # hint : the result is sorted by title.biblionumber because we can have X biblios with the same title
2023 # and we don't want to get only 1 result for each of them !!!
2024 # hint & speed improvement : we can order without reading the record
2025 # so order, and read records only for the requested page !
2026 $result{ $title . $biblionumber } = $biblionumber;
2029 # sort the hash and return the same structure as GetRecords (Zebra querying)
2032 if ( $ordering eq 'title_az' ) { # sort by title desc
2033 foreach my $key ( sort ( keys %result ) ) {
2034 $result_hash->{'RECORDS'}[ $numbers++ ] = $result{$key};
2037 else { # sort by title ASC
2038 foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
2039 $result_hash->{'RECORDS'}[ $numbers++ ] = $result{$key};
2043 # limit the $results_per_page to result size if it's more
2044 $results_per_page = $numbers - 1 if $numbers < $results_per_page;
2046 # for the requested page, replace biblionumber by the complete record
2047 # speed improvement : avoid reading too much things
2049 my $counter = $offset ;
2050 $counter <= $offset + $results_per_page ;
2054 $result_hash->{'RECORDS'}[$counter] =
2055 GetMarcBiblio( $result_hash->{'RECORDS'}[$counter] )->as_usmarc;
2057 my $finalresult = ();
2058 $result_hash->{'hits'} = $numbers;
2059 $finalresult->{'biblioserver'} = $result_hash;
2060 return $finalresult;
2067 # we need 2 hashes to order by ranking : the 1st one to count the ranking, the 2nd to order by ranking
2070 foreach ( split /;/, $biblionumbers ) {
2071 my ( $biblionumber, $title ) = split /,/, $_;
2072 $title =~ /(.*)-(\d)/;
2077 # note that we + the ranking because ranking is calculated on weight of EACH term requested.
2078 # if we ask for "two towers", and "two" has weight 2 in biblio N, and "towers" has weight 4 in biblio N
2079 # biblio N has ranking = 6
2080 $count_ranking{$biblionumber} += $ranking;
2083 # build the result by "inverting" the count_ranking hash
2084 # hing : as usual, we don't order by ranking only, to avoid having only 1 result for each rank. We build an hash on concat(ranking,biblionumber) instead
2086 foreach ( keys %count_ranking ) {
2087 $result{ sprintf( "%10d", $count_ranking{$_} ) . '-' . $_ } = $_;
2090 # sort the hash and return the same structure as GetRecords (Zebra querying)
2093 foreach my $key ( sort { $b cmp $a } ( keys %result ) ) {
2094 $result_hash->{'RECORDS'}[ $numbers++ ] = $result{$key};
2097 # limit the $results_per_page to result size if it's more
2098 $results_per_page = $numbers - 1 if $numbers < $results_per_page;
2100 # for the requested page, replace biblionumber by the complete record
2101 # speed improvement : avoid reading too much things
2103 my $counter = $offset ;
2104 $counter <= $offset + $results_per_page ;
2108 $result_hash->{'RECORDS'}[$counter] =
2109 GetMarcBiblio( $result_hash->{'RECORDS'}[$counter] )->as_usmarc
2110 if $result_hash->{'RECORDS'}[$counter];
2112 my $finalresult = ();
2113 $result_hash->{'hits'} = $numbers;
2114 $finalresult->{'biblioserver'} = $result_hash;
2115 return $finalresult;
2121 ($countchanged,$listunchanged) = ModBiblios($listbiblios, $tagsubfield,$initvalue,$targetvalue,$test);
2123 this function changes all the values $initvalue in subfield $tag$subfield in any record in $listbiblios
2124 test parameter if set donot perform change to records in database.
2130 * $listbiblios is an array ref to marcrecords to be changed
2131 * $tagsubfield is the reference of the subfield to change.
2132 * $initvalue is the value to search the record for
2133 * $targetvalue is the value to set the subfield to
2134 * $test is to be set only not to perform changes in database.
2136 =item C<Output arg:>
2137 * $countchanged counts all the changes performed.
2138 * $listunchanged contains the list of all the biblionumbers of records unchanged.
2140 =item C<usage in the script:>
2144 my ($countchanged, $listunchanged) = EditBiblios($results->{RECORD}, $tagsubfield,$initvalue,$targetvalue);;
2145 #If one wants to display unchanged records, you should get biblios foreach @$listunchanged
2146 $template->param(countchanged => $countchanged, loopunchanged=>$listunchanged);
2151 my ( $listbiblios, $tagsubfield, $initvalue, $targetvalue, $test ) = @_;
2154 my ( $tag, $subfield ) = ( $1, $2 )
2155 if ( $tagsubfield =~ /^(\d{1,3})([a-z0-9A-Z@])?$/ );
2156 if ( ( length($tag) < 3 ) && $subfield =~ /0-9/ ) {
2157 $tag = $tag . $subfield;
2160 my ( $bntag, $bnsubf ) = GetMarcFromKohaField('biblio.biblionumber');
2161 my ( $itemtag, $itemsubf ) = GetMarcFromKohaField('items.itemnumber');
2162 if ($tag eq $itemtag) {
2163 # do not allow the embedded item tag to be
2165 warn "Attempting to edit item tag via C4::Search::ModBiblios -- not allowed";
2168 foreach my $usmarc (@$listbiblios) {
2170 $record = eval { MARC::Record->new_from_usmarc($usmarc) };
2174 # usmarc is not a valid usmarc May be a biblionumber
2175 # FIXME - sorry, please let's figure out whether
2176 # this function is to be passed a list of
2177 # record numbers or a list of MARC::Record
2178 # objects. The former is probably better
2179 # because the MARC records supplied by Zebra
2180 # may be not current.
2181 $record = GetMarcBiblio($usmarc);
2182 $biblionumber = $usmarc;
2185 if ( $bntag >= 010 ) {
2186 $biblionumber = $record->subfield( $bntag, $bnsubf );
2189 $biblionumber = $record->field($bntag)->data;
2193 #GetBiblionumber is to be written.
2194 #Could be replaced by TransformMarcToKoha (But Would be longer)
2195 if ( $record->field($tag) ) {
2197 foreach my $field ( $record->field($tag) ) {
2200 $field->delete_subfield(
2201 'code' => $subfield,
2202 'match' => qr($initvalue)
2208 $field->update( $subfield, $targetvalue )
2213 if ( $tag >= 010 ) {
2214 if ( $field->delete_field($field) ) {
2220 $field->data = $targetvalue
2221 if ( $field->data =~ qr($initvalue) );
2226 # warn $record->as_formatted;
2228 ModBiblio( $record, $biblionumber,
2229 GetFrameworkCode($biblionumber) )
2233 push @unmatched, $biblionumber;
2237 push @unmatched, $biblionumber;
2240 return ( $countmatched, \@unmatched );
2243 END { } # module clean-up code here (global destructor)
2250 Koha Developement team <info@koha.org>