4 # Copyright (C) 2004-2007 Frank Lichtenheld <frank@lichtenheld.de>
6 # The code is based on the old search_packages.pl script that
9 # Copyright (C) 1998 James Treacy
10 # Copyright (C) 2000, 2001 Josip Rodin
11 # Copyright (C) 2001 Adam Heath
12 # Copyright (C) 2004 Martin Schulze
14 # This program is free software; you can redistribute it and/or modify
15 # it under the terms of the GNU General Public License as published by
16 # the Free Software Foundation; either version 1 of the License, or
17 # (at your option) any later version.
19 # This program is distributed in the hope that it will be useful,
20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 # GNU General Public License for more details.
24 # You should have received a copy of the GNU General Public License
25 # along with this program; if not, write to the Free Software
26 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
41 package Packages::Search;
49 use Lingua::Stem v0.82;
50 use Search::Xapian qw(:ops);
56 our @ISA = qw( Exporter );
58 our @EXPORT_OK = qw( read_entry read_entry_all read_entry_simple
59 read_src_entry read_src_entry_all find_binaries
60 do_names_search do_fulltext_search do_xapian_search
63 our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
67 our $too_many_hits = 0;
70 my ($hash, $key, $results, $non_results, $opts) = @_;
71 my ($virt, $result) = split /\000/o, $hash->{$key} || "-\01-", 2;
73 my %virt = split /\01/o, $virt;
74 while (my ($suite, $provides) = each %virt) {
75 next if $suite eq '-';
76 if ($opts->{h_suites}{$suite}) {
77 push @$results, [ $key, "-", $suite, 'virtual', 'v', 'v', 'v', 'v',
80 push @$non_results, [ $key, "-", $suite, 'virtual', 'v', 'v', 'v', 'v',
85 foreach (split(/\000/o, $result||'')) {
86 my @data = split ( /\s/o, $_, 8 );
87 debug( "Considering entry ".join( ':', @data), 2) if DEBUG;
88 if ($opts->{h_suites}{$data[1]}
89 && ($opts->{h_archs}{$data[2]} || $data[2] eq 'all')
90 && $opts->{h_sections}{$data[3]}) {
91 debug( "Using entry ".join( ':', @data), 2) if DEBUG;
92 push @$results, [ $key, @data ];
94 push @$non_results, [ $key, @data ];
99 my ($hash, $key, $results, $opts) = @_;
101 read_entry_all( $hash, $key, $results, \@non_results, $opts );
106 if ($suite =~ /^(\S+)-(?:updates|backports)/) {
113 sub read_entry_simple {
114 my ($hash, $key, $archives, $suite) = @_;
115 # FIXME: drop $archives
117 my ($virt, $result) = split /\000/o, $hash->{$key} || "-\01-\0", 2;
118 my %virt = split /\01/o, $virt;
119 debug( "read_entry_simple: key=$key, archives=".
120 join(" ",(keys %$archives)).", suite=$suite", 1) if DEBUG;
121 debug( "read_entry_simple: virt=".join(" ",(%virt)), 2) if DEBUG;
122 # FIXME: not all of the 2^4=16 combinations of empty(results),
123 # empty(virt{suite}), empty(fb_result), empty(virt{fb_suite}) are dealt
124 # with correctly, but it's adequate enough for now
125 return [ $virt{$suite} ] unless defined $result;
126 foreach (split /\000/o, $result) {
127 my @data = split ( /\s/o, $_, 8 );
128 debug( "use entry: @data", 2 ) if DEBUG && $data[1] eq $suite;
129 return [ $virt{$suite}, @data ] if $data[1] eq $suite;
131 if (my $fb_suite = fallback_suite($suite)) {
132 my $fb_result = read_entry_simple( $hash, $key, $archives, $fb_suite );
133 my $fb_virt = shift(@$fb_result);
134 $virt{$suite} .= $virt{$suite} ? " $fb_virt" : $fb_virt if $fb_virt;
135 return [ $virt{$suite}, @$fb_result ] if @$fb_result;
137 return [ $virt{$suite} ];
140 sub read_src_entry_all {
141 my ($hash, $key, $results, $non_results, $opts) = @_;
142 my $result = $hash->{$key} || '';
143 debug( "read_src_entry_all: key=$key", 1) if DEBUG;
144 foreach (split /\000/o, $result) {
145 my @data = split ( /\s/o, $_, 6 );
146 debug( "Considering entry ".join( ':', @data), 2) if DEBUG;
147 if ($opts->{h_archives}{$data[0]}
148 && $opts->{h_suites}{$data[1]}
149 && $opts->{h_sections}{$data[2]}) {
150 debug( "Using entry ".join( ':', @data), 2) if DEBUG;
151 push @$results, [ $key, @data ];
153 push @$non_results, [ $key, @data ];
158 my ($hash, $key, $results, $opts) = @_;
160 read_src_entry_all( $hash, $key, $results, \@non_results, $opts );
162 sub do_names_search {
163 my ($keywords, $packages, $postfixes, $read_entry, $opts,
164 $results, $non_results) = @_;
166 my $first_keyword = lc shift @$keywords;
167 @$keywords = map { lc $_ } @$keywords;
169 my ($key, $prefixes) = ($first_keyword, '');
171 $postfixes->seq( $key, $prefixes, R_CURSOR );
172 while (index($key, $first_keyword) >= 0) {
173 if ($prefixes =~ /^\001(\d+)/o) {
174 debug( "$key has too many hits", 2 ) if DEBUG;
175 $too_many_hits += $1;
178 foreach (split /\000/o, $prefixes) {
179 $_ = '' if $_ eq '^';
181 foreach my $k (@$keywords) {
182 next PREFIX unless $word =~ /\Q$k\E/;
184 debug( "add word $word", 2) if DEBUG;
188 last if $postfixes->seq( $key, $prefixes, R_NEXT ) != 0;
189 last if $too_many_hits or keys %pkgs >= 100;
192 my $no_results = keys %pkgs;
193 if ($too_many_hits || ($no_results >= 100)) {
194 $too_many_hits += $no_results;
195 %pkgs = ( $first_keyword => 1 ) unless @$keywords;
197 foreach my $pkg (sort keys %pkgs) {
198 &$read_entry( $packages, $pkg, $results, $non_results, $opts );
202 sub do_xapian_search {
203 my ($keywords, $dbpath, $did2pkg, $packages, $read_entry, $opts,
204 $results, $non_results) = @_;
206 # NOTE: this needs to correspond with parse-packages!
208 foreach my $keyword (@$keywords) {
209 $keyword =~ s;[^\w/+]+; ;og;
212 my $stemmer = Lingua::Stem->new();
213 my @stemmed_keywords = grep { length($_) } @{$stemmer->stem( @tmp )};
215 my $db = Search::Xapian::Database->new( $dbpath );
216 my $enq = $db->enquire( OP_OR, @$keywords, @stemmed_keywords );
217 debug( "Xapian Query was: ".$enq->get_query()->get_description(), 1) if DEBUG;
218 my @matches = $enq->matches(0, 999);
220 my (@order, %tmp_results);
221 foreach my $match ( @matches ) {
222 my $id = $match->get_docid();
223 my $result = $did2pkg->{$id};
225 foreach (split /\000/o, $result) {
226 my @data = split /\s/, $_, 3;
227 debug ("Considering $data[0], arch = $data[2], relevance=".$match->get_percent(), 3) if DEBUG;
228 # next unless $data[2] eq 'all' || $opts->{h_archs}{$data[2]};
229 # debug ("Ok", 3) if DEBUG;
230 unless ($tmp_results{$data[0]}++) {
231 push @order, $data[0];
234 last if @order > 100;
237 $too_many_hits++ if @order > 100;
239 debug ("ORDER: @order", 2) if DEBUG;
240 foreach my $pkg (@order) {
241 &$read_entry( $packages, $pkg, $results, $non_results, $opts );
246 my ($pkg, $dbpath, $did2pkg) = @_;
248 my $db = Search::Xapian::Database->new( $dbpath );
249 my $enq = $db->enquire( "P$pkg" );
250 debug( "Xapian Query was: ".$enq->get_query()->get_description(), 1) if DEBUG;
251 my $first_match = ($enq->matches(0,1))[0]->get_document();
254 my $term_it = $first_match->termlist_begin();
255 my $term_end = $first_match->termlist_end();
257 for (; $term_it ne $term_end; $term_it++) {
258 debug( "TERM: ".$term_it->get_termname(), 3);
259 push @terms, $term_it->get_termname();
262 my $rel_enq = $db->enquire( OP_OR, @terms );
263 debug( "Xapian Query was: ".$rel_enq->get_query()->get_description(), 1) if DEBUG;
264 my @rel_pkg = $rel_enq->matches(2,20);
267 # debug(Dumper(\@rel_pkg),1);
269 my (@order, %tmp_results);
270 foreach my $match ( @rel_pkg ) {
271 my $id = $match->get_docid();
272 my $result = $did2pkg->{$id};
274 foreach (split /\000/o, $result) {
275 my @data = split /\s/, $_, 3;
276 debug ("Considering $data[0], arch = $data[2], relevance=".$match->get_percent(), 3) if DEBUG;
277 next if $data[0] eq $pkg;
278 unless ($tmp_results{$data[0]}++) {
279 push @order, $data[0];
285 debug ("ORDER: @order", 2) if DEBUG;
286 return @order[0..10];
290 my ($pkg, $archive, $suite, $src2bin) = @_;
292 my $bins = $src2bin->{$pkg} || '';
294 foreach (split /\000/o, $bins) {
295 my @data = split /\s/, $_, 5;
297 debug( "find_binaries: considering @data", 3 ) if DEBUG;
298 if (($data[0] eq $archive)
299 && ($data[1] eq $suite)) {
301 debug( "find_binaries: using @data", 3 ) if DEBUG;
305 return [ keys %bins ];