Move CPANPLUS from lib/ to ext/
[p5sagit/p5-mst-13.2.git] / ext / CPANPLUS / lib / CPANPLUS / Internals / Search.pm
CommitLineData
6aaee015 1package CPANPLUS::Internals::Search;
2
3use strict;
4
5use CPANPLUS::Error;
6use CPANPLUS::Internals::Constants;
7use CPANPLUS::Module;
8use CPANPLUS::Module::Author;
9
10use File::Find;
11use File::Spec;
12
13use Params::Check qw[check allow];
14use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
15
16$Params::Check::VERBOSE = 1;
17
18=pod
19
20=head1 NAME
21
22CPANPLUS::Internals::Search
23
24=head1 SYNOPSIS
25
26 my $aref = $cpan->_search_module_tree(
27 type => 'package',
28 allow => [qr/DBI/],
29 );
30
31 my $aref = $cpan->_search_author_tree(
32 type => 'cpanid',
33 data => \@old_results,
34 verbose => 1,
35 allow => [qw|KANE AUTRIJUS|],
36 );
37
38 my $aref = $cpan->_all_installed( );
39
40=head1 DESCRIPTION
41
42The functions in this module are designed to find module(objects)
43based on certain criteria and return them.
44
45=head1 METHODS
46
4443dd53 47=head2 _search_module_tree( type => TYPE, allow => \@regexes, [data => \@previous_results ] )
6aaee015 48
49Searches the moduletree for module objects matching the criteria you
50specify. Returns an array ref of module objects on success, and false
51on failure.
52
53It takes the following arguments:
54
55=over 4
56
57=item type
58
59This can be any of the accessors for the C<CPANPLUS::Module> objects.
60This is a required argument.
61
62=item allow
63
64A set of rules, or more precisely, a list of regexes (via C<qr//> or
65plain strings), that the C<type> must adhere too. You can specify as
66many as you like, and it will be treated as an C<OR> search.
67For an C<AND> search, see the C<data> argument.
68
69This is a required argument.
70
71=item data
72
73An arrayref of previous search results. This is the way to do an C<AND>
74search -- C<_search_module_tree> will only search the module objects
75specified in C<data> if provided, rather than the moduletree itself.
76
77=back
78
79=cut
80
81# Although the Params::Check solution is more graceful, it is WAY too slow.
82#
83# This sample script:
84#
85# use CPANPLUS::Backend;
86# my $cb = new CPANPLUS::Backend;
87# $cb->module_tree;
88# my @list = $cb->search( type => 'module', allow => [qr/^Acme/] );
89# print $_->module, $/ for @list;
90#
91# Produced the following output using Dprof WITH params::check code
92#
93# Total Elapsed Time = 3.670024 Seconds
94# User+System Time = 3.390373 Seconds
95# Exclusive Times
96# %Time ExclSec CumulS #Calls sec/call Csec/c Name
97# 88.7 3.008 4.463 20610 0.0001 0.0002 Params::Check::check
98# 47.4 1.610 1.610 1 1.6100 1.6100 Storable::net_pstore
99# 25.6 0.869 0.737 20491 0.0000 0.0000 Locale::Maketext::Simple::_default
100# _gettext
101# 23.2 0.789 0.524 40976 0.0000 0.0000 Params::Check::_who_was_it
102# 23.2 0.789 0.677 20610 0.0000 0.0000 Params::Check::_sanity_check
103# 19.7 0.670 0.670 1 0.6700 0.6700 Storable::pretrieve
104# 14.1 0.480 0.211 41350 0.0000 0.0000 Params::Check::_convert_case
105# 11.5 0.390 0.256 20610 0.0000 0.0000 Params::Check::_hashdefs
106# 11.5 0.390 0.255 20697 0.0000 0.0000 Params::Check::_listreqs
107# 11.4 0.389 0.177 20653 0.0000 0.0000 Params::Check::_canon_key
108# 10.9 0.370 0.356 20697 0.0000 0.0000 Params::Check::_hasreq
109# 8.02 0.272 4.750 1 0.2723 4.7501 CPANPLUS::Internals::Search::_sear
110# ch_module_tree
111# 6.49 0.220 0.086 20653 0.0000 0.0000 Params::Check::_iskey
112# 6.19 0.210 0.077 20488 0.0000 0.0000 Params::Check::_store_error
113# 5.01 0.170 0.036 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__
114#
115# and this output /without/
116#
117# Total Elapsed Time = 2.803426 Seconds
118# User+System Time = 2.493426 Seconds
119# Exclusive Times
120# %Time ExclSec CumulS #Calls sec/call Csec/c Name
121# 56.9 1.420 1.420 1 1.4200 1.4200 Storable::net_pstore
122# 25.6 0.640 0.640 1 0.6400 0.6400 Storable::pretrieve
123# 9.22 0.230 0.096 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__
124# 7.06 0.176 0.272 1 0.1762 0.2719 CPANPLUS::Internals::Search::_sear
125# ch_module_tree
126# 3.21 0.080 0.098 10 0.0080 0.0098 IPC::Cmd::BEGIN
127# 1.60 0.040 0.205 13 0.0031 0.0158 CPANPLUS::Internals::BEGIN
128# 1.20 0.030 0.030 29 0.0010 0.0010 vars::BEGIN
129# 1.20 0.030 0.117 10 0.0030 0.0117 Log::Message::BEGIN
130# 1.20 0.030 0.029 9 0.0033 0.0033 CPANPLUS::Internals::Search::BEGIN
131# 0.80 0.020 0.020 5 0.0040 0.0040 DynaLoader::dl_load_file
132# 0.80 0.020 0.127 10 0.0020 0.0127 CPANPLUS::Module::BEGIN
133# 0.80 0.020 0.389 2 0.0099 0.1944 main::BEGIN
134# 0.80 0.020 0.359 12 0.0017 0.0299 CPANPLUS::Backend::BEGIN
135# 0.40 0.010 0.010 30 0.0003 0.0003 Config::FETCH
136# 0.40 0.010 0.010 18 0.0006 0.0005 Locale::Maketext::Simple::load_loc
137#
138
139sub _search_module_tree {
4443dd53 140
6aaee015 141 my $self = shift;
142 my $conf = $self->configure_object;
143 my %hash = @_;
144
145 my($mods,$list,$verbose,$type);
146 my $tmpl = {
4443dd53 147 data => { default => [],
6aaee015 148 strict_type=> 1, store => \$mods },
149 allow => { required => 1, default => [ ], strict_type => 1,
150 store => \$list },
151 verbose => { default => $conf->get_conf('verbose'),
152 store => \$verbose },
153 type => { required => 1, allow => [CPANPLUS::Module->accessors()],
154 store => \$type },
155 };
156
4443dd53 157 my $args = do {
158 ### don't check the template for sanity
159 ### -- we know it's good and saves a lot of performance
160 local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
6aaee015 161
4443dd53 162 check( $tmpl, \%hash );
163 } or return;
164
165 ### a list of module objects was supplied
166 if( @$mods ) {
167 local $Params::Check::VERBOSE = 0;
6aaee015 168
169 my @rv;
170 for my $mod (@$mods) {
171 #push @rv, $mod if check(
172 # { $type => { allow => $list } },
173 # { $type => $mod->$type() }
174 # );
175 push @rv, $mod if allow( $mod->$type() => $list );
176
177 }
178 return \@rv;
4443dd53 179
180 } else {
181 my @rv = $self->_source_search_module_tree(
182 allow => $list,
183 type => $type,
184 );
185 return \@rv;
6aaee015 186 }
187}
188
189=pod
190
191=head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] )
192
193Searches the authortree for author objects matching the criteria you
194specify. Returns an array ref of author objects on success, and false
195on failure.
196
197It takes the following arguments:
198
199=over 4
200
201=item type
202
203This can be any of the accessors for the C<CPANPLUS::Module::Author>
204objects. This is a required argument.
205
206=item allow
207
208
209A set of rules, or more precisely, a list of regexes (via C<qr//> or
210plain strings), that the C<type> must adhere too. You can specify as
211many as you like, and it will be treated as an C<OR> search.
212For an C<AND> search, see the C<data> argument.
213
214This is a required argument.
215
216=item data
217
218An arrayref of previous search results. This is the way to do an C<and>
219search -- C<_search_author_tree> will only search the author objects
220specified in C<data> if provided, rather than the authortree itself.
221
222=back
223
224=cut
225
226sub _search_author_tree {
227 my $self = shift;
228 my $conf = $self->configure_object;
229 my %hash = @_;
230
231 my($authors,$list,$verbose,$type);
232 my $tmpl = {
4443dd53 233 data => { default => [],
6aaee015 234 strict_type=> 1, store => \$authors },
235 allow => { required => 1, default => [ ], strict_type => 1,
236 store => \$list },
237 verbose => { default => $conf->get_conf('verbose'),
238 store => \$verbose },
239 type => { required => 1, allow => [CPANPLUS::Module::Author->accessors()],
240 store => \$type },
241 };
242
243 my $args = check( $tmpl, \%hash ) or return;
244
4443dd53 245 if( @$authors ) {
246 local $Params::Check::VERBOSE = 0;
6aaee015 247
248 my @rv;
249 for my $auth (@$authors) {
250 #push @rv, $auth if check(
251 # { $type => { allow => $list } },
252 # { $type => $auth->$type }
253 # );
254 push @rv, $auth if allow( $auth->$type() => $list );
255 }
256 return \@rv;
4443dd53 257 } else {
258 my @rv = $self->_source_search_author_tree(
259 allow => $list,
260 type => $type,
261 );
262 return \@rv;
6aaee015 263 }
6aaee015 264}
265
266=pod
267
268=head2 _all_installed()
269
270This function returns an array ref of module objects of modules that
271are installed on this system.
272
273=cut
274
275sub _all_installed {
276 my $self = shift;
277 my $conf = $self->configure_object;
278 my %hash = @_;
279
5bc5f6dc 280 ### File::Find uses follow_skip => 1 by default, which doesn't die
281 ### on duplicates, unless they are directories or symlinks.
282 ### Ticket #29796 shows this code dying on Alien::WxWidgets,
283 ### which uses symlinks.
284 ### File::Find doc says to use follow_skip => 2 to ignore duplicates
285 ### so this will stop it from dying.
286 my %find_args = ( follow_skip => 2 );
6aaee015 287
288 ### File::Find uses lstat, which quietly becomes stat on win32
289 ### it then uses -l _ which is not allowed by the statbuffer because
290 ### you did a stat, not an lstat (duh!). so don't tell win32 to
291 ### follow symlinks, as that will break badly
5bc5f6dc 292 $find_args{'follow_fast'} = 1 unless ON_WIN32;
6aaee015 293
294 ### never use the @INC hooks to find installed versions of
295 ### modules -- they're just there in case they're not on the
296 ### perl install, but the user shouldn't trust them for *other*
297 ### modules!
298 ### XXX CPANPLUS::inc is now obsolete, remove the calls
299 #local @INC = CPANPLUS::inc->original_inc;
300
5bc5f6dc 301 my %seen; my @rv;
6aaee015 302 for my $dir (@INC ) {
303 next if $dir eq '.';
304
5bc5f6dc 305 ### not a directory after all
306 ### may be coderef or some such
6aaee015 307 next unless -d $dir;
308
309 ### make sure to clean up the directories just in case,
310 ### as we're making assumptions about the length
311 ### This solves rt.cpan issue #19738
5bc5f6dc 312
313 ### John M. notes: On VMS cannonpath can not currently handle
314 ### the $dir values that are in UNIX format.
315 $dir = File::Spec->canonpath( $dir ) unless ON_VMS;
316
317 ### have to use F::S::Unix on VMS, or things will break
318 my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec';
319
320 ### XXX in some cases File::Find can actually die!
321 ### so be safe and wrap it in an eval.
322 eval { File::Find::find(
6aaee015 323 { %find_args,
324 wanted => sub {
325
326 return unless /\.pm$/i;
327 my $mod = $File::Find::name;
328
5bc5f6dc 329 ### make sure it's in Unix format, as it
330 ### may be in VMS format on VMS;
331 $mod = VMS::Filespec::unixify( $mod ) if ON_VMS;
332
6aaee015 333 $mod = substr($mod, length($dir) + 1, -3);
5bc5f6dc 334 $mod = join '::', $file_spec->splitdir($mod);
6aaee015 335
336 return if $seen{$mod}++;
5bc5f6dc 337
5879cbe1 338 my $modobj = $self->module_tree($mod);
5bc5f6dc 339
340 ### seperate return, a list context return with one ''
341 ### in it, is also true!
342 return unless $modobj;
6aaee015 343
344 push @rv, $modobj;
345 },
346 }, $dir
5bc5f6dc 347 ) };
348
349 ### report the error if file::find died
350 error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@;
6aaee015 351 }
352
353 return \@rv;
354}
355
3561;
357
358# Local variables:
359# c-indentation-style: bsd
360# c-basic-offset: 4
361# indent-tabs-mode: nil
362# End:
363# vim: expandtab shiftwidth=4: