Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::Internals::Search; |
2 | |
3 | use strict; |
4 | |
5 | use CPANPLUS::Error; |
6 | use CPANPLUS::Internals::Constants; |
7 | use CPANPLUS::Module; |
8 | use CPANPLUS::Module::Author; |
9 | |
10 | use File::Find; |
11 | use File::Spec; |
12 | |
13 | use Params::Check qw[check allow]; |
14 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
15 | |
16 | $Params::Check::VERBOSE = 1; |
17 | |
18 | =pod |
19 | |
20 | =head1 NAME |
21 | |
22 | CPANPLUS::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 | |
42 | The functions in this module are designed to find module(objects) |
43 | based 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 | |
49 | Searches the moduletree for module objects matching the criteria you |
50 | specify. Returns an array ref of module objects on success, and false |
51 | on failure. |
52 | |
53 | It takes the following arguments: |
54 | |
55 | =over 4 |
56 | |
57 | =item type |
58 | |
59 | This can be any of the accessors for the C<CPANPLUS::Module> objects. |
60 | This is a required argument. |
61 | |
62 | =item allow |
63 | |
64 | A set of rules, or more precisely, a list of regexes (via C<qr//> or |
65 | plain strings), that the C<type> must adhere too. You can specify as |
66 | many as you like, and it will be treated as an C<OR> search. |
67 | For an C<AND> search, see the C<data> argument. |
68 | |
69 | This is a required argument. |
70 | |
71 | =item data |
72 | |
73 | An arrayref of previous search results. This is the way to do an C<AND> |
74 | search -- C<_search_module_tree> will only search the module objects |
75 | specified 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 | |
139 | sub _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 | |
193 | Searches the authortree for author objects matching the criteria you |
194 | specify. Returns an array ref of author objects on success, and false |
195 | on failure. |
196 | |
197 | It takes the following arguments: |
198 | |
199 | =over 4 |
200 | |
201 | =item type |
202 | |
203 | This can be any of the accessors for the C<CPANPLUS::Module::Author> |
204 | objects. This is a required argument. |
205 | |
206 | =item allow |
207 | |
208 | |
209 | A set of rules, or more precisely, a list of regexes (via C<qr//> or |
210 | plain strings), that the C<type> must adhere too. You can specify as |
211 | many as you like, and it will be treated as an C<OR> search. |
212 | For an C<AND> search, see the C<data> argument. |
213 | |
214 | This is a required argument. |
215 | |
216 | =item data |
217 | |
218 | An arrayref of previous search results. This is the way to do an C<and> |
219 | search -- C<_search_author_tree> will only search the author objects |
220 | specified in C<data> if provided, rather than the authortree itself. |
221 | |
222 | =back |
223 | |
224 | =cut |
225 | |
226 | sub _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 | |
270 | This function returns an array ref of module objects of modules that |
271 | are installed on this system. |
272 | |
273 | =cut |
274 | |
275 | sub _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 | |
356 | 1; |
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: |