# # Packages::Search # # Copyright (C) 2004-2007 Frank Lichtenheld # # The code is based on the old search_packages.pl script that # was: # # Copyright (C) 1998 James Treacy # Copyright (C) 2000, 2001 Josip Rodin # Copyright (C) 2001 Adam Heath # Copyright (C) 2004 Martin Schulze # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 1 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. # =head1 NAME Packages::Search - =head1 SYNOPSIS =head1 DESCRIPTION =over 4 =cut package Packages::Search; use strict; use warnings; use POSIX; use HTML::Entities; use DB_File; use Lingua::Stem v0.82; use Search::Xapian qw(:ops); use Deb::Versions; use Packages::CGI; use Exporter; our @ISA = qw( Exporter ); our @EXPORT_OK = qw( read_entry read_entry_all read_entry_simple read_src_entry read_src_entry_all find_binaries do_names_search do_fulltext_search do_xapian_search find_similar ); our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] ); our $VERSION = 0.01; our $too_many_hits = 0; sub read_entry_all { my ($hash, $key, $results, $non_results, $opts) = @_; my ($virt, $result) = split /\000/o, $hash->{$key} || "-\01-", 2; my %virt = split /\01/o, $virt; while (my ($suite, $provides) = each %virt) { next if $suite eq '-'; if ($opts->{h_suites}{$suite}) { push @$results, [ $key, "-", $suite, 'virtual', 'v', 'v', 'v', 'v', $provides]; } else { push @$non_results, [ $key, "-", $suite, 'virtual', 'v', 'v', 'v', 'v', $provides]; } } foreach (split(/\000/o, $result||'')) { my @data = split ( /\s/o, $_, 8 ); debug( "Considering entry ".join( ':', @data), 2) if DEBUG; if ($opts->{h_suites}{$data[1]} && ($opts->{h_archs}{$data[2]} || $data[2] eq 'all') && $opts->{h_sections}{$data[3]}) { debug( "Using entry ".join( ':', @data), 2) if DEBUG; push @$results, [ $key, @data ]; } else { push @$non_results, [ $key, @data ]; } } } sub read_entry { my ($hash, $key, $results, $opts) = @_; my @non_results; read_entry_all( $hash, $key, $results, \@non_results, $opts ); } #FIXME: make configurable my %fallback_suites = ( 'sarge-backports' => 'sarge', 'sarge-volatile' => 'sarge', 'etch-backports' => 'etch', 'etch-volatile' => 'etch', experimental => 'sid' ); sub read_entry_simple { my ($hash, $key, $archives, $suite) = @_; # FIXME: drop $archives my ($virt, $result) = split /\000/o, $hash->{$key} || "-\01-\0", 2; my %virt = split /\01/o, $virt; debug( "read_entry_simple: key=$key, archives=". join(" ",(keys %$archives)).", suite=$suite", 1) if DEBUG; debug( "read_entry_simple: virt=".join(" ",(%virt)), 2) if DEBUG; # FIXME: not all of the 2^4=16 combinations of empty(results), # empty(virt{suite}), empty(fb_result), empty(virt{fb_suite}) are dealt # with correctly, but it's adequate enough for now return [ $virt{$suite} ] unless defined $result; foreach (split /\000/o, $result) { my @data = split ( /\s/o, $_, 8 ); debug( "use entry: @data", 2 ) if DEBUG && $data[1] eq $suite; return [ $virt{$suite}, @data ] if $data[1] eq $suite; } if (my $fb_suite = $fallback_suites{$suite}) { my $fb_result = read_entry_simple( $hash, $key, $archives, $fb_suite ); my $fb_virt = shift(@$fb_result); $virt{$suite} .= $virt{$suite} ? " $fb_virt" : $fb_virt if $fb_virt; return [ $virt{$suite}, @$fb_result ] if @$fb_result; } return [ $virt{$suite} ]; } sub read_src_entry_all { my ($hash, $key, $results, $non_results, $opts) = @_; my $result = $hash->{$key} || ''; debug( "read_src_entry_all: key=$key", 1) if DEBUG; foreach (split /\000/o, $result) { my @data = split ( /\s/o, $_, 6 ); debug( "Considering entry ".join( ':', @data), 2) if DEBUG; if ($opts->{h_archives}{$data[0]} && $opts->{h_suites}{$data[1]} && $opts->{h_sections}{$data[2]}) { debug( "Using entry ".join( ':', @data), 2) if DEBUG; push @$results, [ $key, @data ]; } else { push @$non_results, [ $key, @data ]; } } } sub read_src_entry { my ($hash, $key, $results, $opts) = @_; my @non_results; read_src_entry_all( $hash, $key, $results, \@non_results, $opts ); } sub do_names_search { my ($keywords, $packages, $postfixes, $read_entry, $opts, $results, $non_results) = @_; my $first_keyword = lc shift @$keywords; @$keywords = map { lc $_ } @$keywords; my ($key, $prefixes) = ($first_keyword, ''); my %pkgs; $postfixes->seq( $key, $prefixes, R_CURSOR ); while (index($key, $first_keyword) >= 0) { if ($prefixes =~ /^\001(\d+)/o) { debug( "$key has too many hits", 2 ) if DEBUG; $too_many_hits += $1; } else { PREFIX: foreach (split /\000/o, $prefixes) { $_ = '' if $_ eq '^'; my $word = "$_$key"; foreach my $k (@$keywords) { next PREFIX unless $word =~ /\Q$k\E/; } debug( "add word $word", 2) if DEBUG; $pkgs{$word}++; } } last if $postfixes->seq( $key, $prefixes, R_NEXT ) != 0; last if $too_many_hits or keys %pkgs >= 100; } my $no_results = keys %pkgs; if ($too_many_hits || ($no_results >= 100)) { $too_many_hits += $no_results; %pkgs = ( $first_keyword => 1 ) unless @$keywords; } foreach my $pkg (sort keys %pkgs) { &$read_entry( $packages, $pkg, $results, $non_results, $opts ); } } sub do_xapian_search { my ($keywords, $dbpath, $did2pkg, $packages, $read_entry, $opts, $results, $non_results) = @_; # NOTE: this needs to correspond with parse-packages! my @tmp; foreach my $keyword (@$keywords) { $keyword =~ s;[^\w/+]+; ;og; push @tmp, $keyword; } my $stemmer = Lingua::Stem->new(); my $stemmed_keywords = $stemmer->stem( @tmp ); my $db = Search::Xapian::Database->new( $dbpath ); my $enq = $db->enquire( OP_OR, @$keywords, @$stemmed_keywords ); debug( "Xapian Query was: ".$enq->get_query()->get_description(), 1) if DEBUG; my @matches = $enq->matches(0, 999); my (@order, %tmp_results); foreach my $match ( @matches ) { my $id = $match->get_docid(); my $result = $did2pkg->{$id}; foreach (split /\000/o, $result) { my @data = split /\s/, $_, 3; debug ("Considering $data[0], arch = $data[2], relevance=".$match->get_percent(), 3) if DEBUG; # next unless $data[2] eq 'all' || $opts->{h_archs}{$data[2]}; # debug ("Ok", 3) if DEBUG; unless ($tmp_results{$data[0]}++) { push @order, $data[0]; } } last if @order > 100; } undef $db; $too_many_hits++ if @order > 100; debug ("ORDER: @order", 2) if DEBUG; foreach my $pkg (@order) { &$read_entry( $packages, $pkg, $results, $non_results, $opts ); } } sub find_similar { my ($pkg, $dbpath, $did2pkg) = @_; my $db = Search::Xapian::Database->new( $dbpath ); my $enq = $db->enquire( "P$pkg" ); debug( "Xapian Query was: ".$enq->get_query()->get_description(), 1) if DEBUG; my $first_match = ($enq->matches(0,1))[0]->get_document(); my @terms; my $term_it = $first_match->termlist_begin(); my $term_end = $first_match->termlist_end(); for (; $term_it ne $term_end; $term_it++) { debug( "TERM: ".$term_it->get_termname(), 3); push @terms, $term_it->get_termname(); } my $rel_enq = $db->enquire( OP_OR, @terms ); debug( "Xapian Query was: ".$rel_enq->get_query()->get_description(), 1) if DEBUG; my @rel_pkg = $rel_enq->matches(2,20); # use Data::Dumper; # debug(Dumper(\@rel_pkg),1); my (@order, %tmp_results); foreach my $match ( @rel_pkg ) { my $id = $match->get_docid(); my $result = $did2pkg->{$id}; foreach (split /\000/o, $result) { my @data = split /\s/, $_, 3; debug ("Considering $data[0], arch = $data[2], relevance=".$match->get_percent(), 3) if DEBUG; next if $data[0] eq $pkg; unless ($tmp_results{$data[0]}++) { push @order, $data[0]; } } } undef $db; debug ("ORDER: @order", 2) if DEBUG; return @order[0..10]; } sub find_binaries { my ($pkg, $archive, $suite, $src2bin) = @_; my $bins = $src2bin->{$pkg} || ''; my %bins; foreach (split /\000/o, $bins) { my @data = split /\s/, $_, 5; debug( "find_binaries: considering @data", 3 ) if DEBUG; if (($data[0] eq $archive) && ($data[1] eq $suite)) { $bins{$data[2]}++; debug( "find_binaries: using @data", 3 ) if DEBUG; } } return [ keys %bins ]; } 1;