File Coverage

blib/lib/Slackware/Slackget/Search.pm
Criterion Covered Total %
statement 6 93 6.4
branch 0 40 0.0
condition 0 27 0.0
subroutine 2 9 22.2
pod 7 7 100.0
total 15 176 8.5


line stmt bran cond sub pod time code
1             package Slackware::Slackget::Search;
2              
3 2     2   27775 use warnings;
  2         3  
  2         68  
4 2     2   8 use strict;
  2         2  
  2         1705  
5              
6             =head1 NAME
7              
8             Slackware::Slackget::Search - The slack-get search class
9              
10             =head1 VERSION
11              
12             Version 1.0.0
13              
14             =cut
15              
16             our $VERSION = '1.0.0';
17              
18             =head1 SYNOPSIS
19              
20             A class to search for packages on a Slackware::Slackget::PackageList object. This class is a real search engine (I personnally use it couple with the slack-get daemon, on my website), and it has been designed to be easily tunable.
21              
22             use Slackware::Slackget::Search;
23              
24             my $search = Slackware::Slackget::Search->new($packagelist);
25             my @array = $search->search_package($string); # the simplier, search a matching package name
26             my @array = $search->search_package_in description($string); # More specialyze, search in the package description
27             my @array = $search->search_package_multi_fields($string,@fields); # search in each fields for matching $string
28              
29             All methods return an array of Slackware::Slackget::Package objects.
30              
31             =cut
32              
33             =head1 CONSTRUCTOR
34              
35             =head2 new
36              
37             The constructor take a Slackware::Slackget::PackageList object as argument.
38              
39             my $search = Slackware::Slackget::Search->new($packagelist);
40              
41             =cut
42              
43             sub new
44             {
45 0     0 1   my ($class,$packagelist) = @_ ;
46 0           my $self={};
47 0 0         return undef if(ref($packagelist) ne 'Slackware::Slackget::PackageList');
48 0           $self->{PKGLIST} = $packagelist;
49 0           bless($self,$class);
50 0           return $self;
51             }
52              
53             =head1 FUNCTIONS
54              
55             =head2 search_package
56              
57             This method take a string as parameter search for packages matching the string, and return an array of Slackware::Slackget::Package
58              
59             @packages = $packageslist->search_package('gcc');
60              
61             =cut
62              
63             sub search_package {
64 0     0 1   my ($self,$string) = @_ ;
65 0           my @result;
66 0           foreach (@{$self->{PKGLIST}->get_all()}){
  0            
67 0 0 0       if($_->get_id() =~ /\Q$string\E/i or $_->name() =~ /\Q$string\E/i){
68 0           push @result, $_;
69             }
70             }
71 0           return (@result);
72             }
73              
74             =head2 exact_search
75              
76             This method take a string as parameter search for packages where the id is equal to this string. Return the index of the packages in the list.
77              
78             $idx = $packageslist->exact_search('perl-mime-base64-3.05-noarch-1');
79              
80             =cut
81              
82             sub exact_search
83             {
84 0     0 1   my ($self,$string) = @_ ;
85 0           my @result;
86 0           my $k=0;
87 0           foreach (@{$self->{PKGLIST}->get_all()}){
  0            
88 0 0         next unless(defined($_));
89 0 0         if($_->get_id() eq $string){
90 0           push @result, $k;
91             }
92 0           $k++;
93             }
94 0           return (@result);
95             }
96              
97             =head2 exact_name_search
98              
99             Same as exact_search() but search on the name of the package instead of its id.
100              
101             $idx = $packageslist->exact_search('perl-mime-base64');
102              
103             =cut
104              
105             sub exact_name_search
106             {
107 0     0 1   my ($self,$string) = @_ ;
108 0           my @result;
109 0           my $k=0;
110 0           foreach (@{$self->{PKGLIST}->get_all()}){
  0            
111 0 0         next unless(defined($_));
112 0 0         if($_->name() eq $string){
113 0           push @result, $k;
114             }
115 0           $k++;
116             }
117 0           return (@result);
118             }
119              
120             =head2 search_package_in_description
121              
122             Take a string as parameter, and search for this string in the package description
123              
124             my @array = $search->search_package_in description($string);
125              
126             =cut
127              
128             sub search_package_in_description {
129 0     0 1   my ($self,$string) = @_ ;
130 0           my @result;
131 0           foreach (@{$self->{PKGLIST}->get_all()}){
  0            
132 0 0 0       if($_->get_id() =~ /\Q$string\E/i or $_->description() =~ /\Q$string\E/i){
133 0           push @result, $_;
134             }
135             }
136 0           return (@result);
137             }
138              
139             =head2 search_package_multi_fields
140              
141             Take a string and a fields list as parameter, and search for this string in the package required fields
142              
143             my @array = $search->search_package_multi_fields($string,@fields);
144              
145             TIPS: you can restrict the search domain by providing fields with restrictions, for example :
146              
147             # For a search only in packages from the Slackware source.
148             my @results = $search->search_package_multi_fields('burner', 'package-source=slackware', 'description','name');
149            
150             # For a search only in packages from the Audioslack source, and only i486 packages
151             my @results = $search->search_package_multi_fields('burner', 'package-source=audioslack', 'architecture=i486', 'description','name');
152              
153             =cut
154              
155             sub search_package_multi_fields {
156 0     0 1   my ($self,$string,@fields)=@_;
157 0           my @result;
158             # print STDERR "[Slackware::Slackget::Search->search_package_multi_fields()] (debug) begin the search.\n";
159 0           foreach (@{$self->{PKGLIST}->get_all()}){
  0            
160 0           foreach my $field (@fields)
161             {
162             # print STDERR "[Slackware::Slackget::Search->search_package_multi_fields()] (debug) compare \"$string\" with package ".$_->get_id()." field $field (".$_->getValue($field).")\n";
163 0 0 0       if($field=~ /^([^=]+)=(.+)/)
    0 0        
164             {
165 0 0 0       if(defined($_->getValue($1)) && $_->getValue($1) ne $2)
166             {
167             # print "[search] '$1' => '",$_->getValue($1),"' ne '$2'\n";
168 0           last ;
169             }
170             }
171             elsif($_->get_id() =~ /\Q$string\E/i or (defined($_->getValue($field)) && $_->getValue($field)=~ /\Q$string\E/i)){
172 0           push @result, $_;
173 0           last;
174             }
175             }
176             }
177 0           return (@result);
178             }
179              
180             =head2 multi_search
181              
182             take a reference on an array of string (requests) as first parameters and a reference to an array which contains the list of fields to search in, and perform a search.
183              
184             This method return an array of Slackware::Slackget::Package as a result. The array is sort by pertinences.
185              
186             my @result_array = $search->multi_search(['burn','dvd','cd'],['name','id','description']) ;
187              
188             You can apply the same tips than for the search_package_multi_fields() method, about the restrictions on search fields.
189              
190             =cut
191              
192             sub multi_search
193             {
194 0     0 1   my ($self,$requests,$fields,$opts) = @_ ;
195 0           my @result;
196 0           my $complete_request = join ' ', @{$requests};
  0            
197 0           $complete_request=~ s/^(.+)\s+$/$1/;
198 0           print STDERR "[Slackware::Slackget::Search->multi_search()] (debug) the complete request is \"$complete_request\"\n";
199 0           foreach (@{$self->{PKGLIST}->get_all()})
  0            
200             {
201 0           my $is_result = 0;
202 0           my $cpt = 0 ;
203 0           foreach my $field (@{$fields})
  0            
204             {
205 0           my $field_value;
206 0 0         if($field=~ /^([^=]+)=(.+)/)
207             {
208 0 0 0       if(defined($_->getValue($1)) && $_->getValue($1) ne $2)
    0 0        
209             {
210 0           $is_result = undef;
211 0           last ;
212             }
213             elsif(defined($_->getValue($1)) && $_->getValue($1) eq $2)
214             {
215 0           $cpt+= 5 ;
216             }
217             }
218             else
219             {
220 0 0         next if(!defined($field_value = $_->getValue($field)));
221             }
222 0           foreach my $string (@{$requests})
  0            
223             {
224 0 0 0       next unless(defined($field_value) && defined($complete_request));
225 0           my @tmp;
226 0 0         if(@tmp = $field_value=~ /\Q$complete_request\E/gi){
    0          
227 0           $cpt+= scalar(@tmp)*5 ;
228 0           $is_result += 1;
229             }
230             elsif(@tmp = $field_value=~ /\Q$string\E/gi){ #@tmp = $_->get_id() =~ /\Q$string\E/gi or
231 0           $cpt+= scalar(@tmp)*1.5 ;
232 0           $is_result += 1;
233             }
234            
235             }
236            
237             }
238 0 0         $is_result = 0 if($is_result < (scalar(@{$requests})/2) );
  0            
239 0 0         if($is_result)
240             {
241 0 0 0       print STDERR "[slack-get] (search engine debug) package ",$_->get_id," got a score of $cpt and a 'is_result' of $is_result\n" if($is_result && $cpt);
242 0           $_->setValue('score',$cpt);
243 0           $_->setValue('slackget10-search-version',$VERSION);
244 0           push @result, $_ ;
245             }
246             }
247 0           return @result;
248             }
249              
250             =head1 AUTHOR
251              
252             DUPUIS Arnaud, C<< <a.dupuis@infinityperl.org> >>
253              
254             =head1 BUGS
255              
256             Please report any bugs or feature requests to
257             C<bug-Slackware-Slackget@rt.cpan.org>, or through the web interface at
258             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Slackware-Slackget>.
259             I will be notified, and then you'll automatically be notified of progress on
260             your bug as I make changes.
261              
262             =head1 SUPPORT
263              
264             You can find documentation for this module with the perldoc command.
265              
266             perldoc Slackware::Slackget
267              
268              
269             You can also look for information at:
270              
271             =over 4
272              
273             =item * Infinity Perl website
274              
275             L<http://www.infinityperl.org/category/slack-get>
276              
277             =item * slack-get specific website
278              
279             L<http://slackget.infinityperl.org>
280              
281             =item * RT: CPAN's request tracker
282              
283             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Slackware-Slackget>
284              
285             =item * AnnoCPAN: Annotated CPAN documentation
286              
287             L<http://annocpan.org/dist/Slackware-Slackget>
288              
289             =item * CPAN Ratings
290              
291             L<http://cpanratings.perl.org/d/Slackware-Slackget>
292              
293             =item * Search CPAN
294              
295             L<http://search.cpan.org/dist/Slackware-Slackget>
296              
297             =back
298              
299             =head1 ACKNOWLEDGEMENTS
300              
301             Thanks to Bertrand Dupuis (yes my brother) for his contribution to the documentation.
302              
303             =head1 SEE ALSO
304              
305             =head1 COPYRIGHT & LICENSE
306              
307             Copyright 2005 DUPUIS Arnaud, All Rights Reserved.
308              
309             This program is free software; you can redistribute it and/or modify it
310             under the same terms as Perl itself.
311              
312             =cut
313              
314             1; # End of Slackware::Slackget::Search