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 | |
47 | =head2 _search_module_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] ) |
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 { |
140 | my $self = shift; |
141 | my $conf = $self->configure_object; |
142 | my %hash = @_; |
143 | |
144 | my($mods,$list,$verbose,$type); |
145 | my $tmpl = { |
146 | data => { default => [values %{$self->module_tree}], |
147 | strict_type=> 1, store => \$mods }, |
148 | allow => { required => 1, default => [ ], strict_type => 1, |
149 | store => \$list }, |
150 | verbose => { default => $conf->get_conf('verbose'), |
151 | store => \$verbose }, |
152 | type => { required => 1, allow => [CPANPLUS::Module->accessors()], |
153 | store => \$type }, |
154 | }; |
155 | |
156 | my $args = check( $tmpl, \%hash ) or return; |
157 | |
158 | { local $Params::Check::VERBOSE = 0; |
159 | |
160 | my @rv; |
161 | for my $mod (@$mods) { |
162 | #push @rv, $mod if check( |
163 | # { $type => { allow => $list } }, |
164 | # { $type => $mod->$type() } |
165 | # ); |
166 | push @rv, $mod if allow( $mod->$type() => $list ); |
167 | |
168 | } |
169 | return \@rv; |
170 | } |
171 | } |
172 | |
173 | =pod |
174 | |
175 | =head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] ) |
176 | |
177 | Searches the authortree for author objects matching the criteria you |
178 | specify. Returns an array ref of author objects on success, and false |
179 | on failure. |
180 | |
181 | It takes the following arguments: |
182 | |
183 | =over 4 |
184 | |
185 | =item type |
186 | |
187 | This can be any of the accessors for the C<CPANPLUS::Module::Author> |
188 | objects. This is a required argument. |
189 | |
190 | =item allow |
191 | |
192 | |
193 | A set of rules, or more precisely, a list of regexes (via C<qr//> or |
194 | plain strings), that the C<type> must adhere too. You can specify as |
195 | many as you like, and it will be treated as an C<OR> search. |
196 | For an C<AND> search, see the C<data> argument. |
197 | |
198 | This is a required argument. |
199 | |
200 | =item data |
201 | |
202 | An arrayref of previous search results. This is the way to do an C<and> |
203 | search -- C<_search_author_tree> will only search the author objects |
204 | specified in C<data> if provided, rather than the authortree itself. |
205 | |
206 | =back |
207 | |
208 | =cut |
209 | |
210 | sub _search_author_tree { |
211 | my $self = shift; |
212 | my $conf = $self->configure_object; |
213 | my %hash = @_; |
214 | |
215 | my($authors,$list,$verbose,$type); |
216 | my $tmpl = { |
217 | data => { default => [values %{$self->author_tree}], |
218 | strict_type=> 1, store => \$authors }, |
219 | allow => { required => 1, default => [ ], strict_type => 1, |
220 | store => \$list }, |
221 | verbose => { default => $conf->get_conf('verbose'), |
222 | store => \$verbose }, |
223 | type => { required => 1, allow => [CPANPLUS::Module::Author->accessors()], |
224 | store => \$type }, |
225 | }; |
226 | |
227 | my $args = check( $tmpl, \%hash ) or return; |
228 | |
229 | { local $Params::Check::VERBOSE = 0; |
230 | |
231 | my @rv; |
232 | for my $auth (@$authors) { |
233 | #push @rv, $auth if check( |
234 | # { $type => { allow => $list } }, |
235 | # { $type => $auth->$type } |
236 | # ); |
237 | push @rv, $auth if allow( $auth->$type() => $list ); |
238 | } |
239 | return \@rv; |
240 | } |
241 | |
242 | |
243 | } |
244 | |
245 | =pod |
246 | |
247 | =head2 _all_installed() |
248 | |
249 | This function returns an array ref of module objects of modules that |
250 | are installed on this system. |
251 | |
252 | =cut |
253 | |
254 | sub _all_installed { |
255 | my $self = shift; |
256 | my $conf = $self->configure_object; |
257 | my %hash = @_; |
258 | |
259 | my %seen; my @rv; |
260 | |
261 | |
262 | ### File::Find uses lstat, which quietly becomes stat on win32 |
263 | ### it then uses -l _ which is not allowed by the statbuffer because |
264 | ### you did a stat, not an lstat (duh!). so don't tell win32 to |
265 | ### follow symlinks, as that will break badly |
266 | my %find_args = (); |
267 | $find_args{'follow_fast'} = 1 unless $^O eq 'MSWin32'; |
268 | |
269 | ### never use the @INC hooks to find installed versions of |
270 | ### modules -- they're just there in case they're not on the |
271 | ### perl install, but the user shouldn't trust them for *other* |
272 | ### modules! |
273 | ### XXX CPANPLUS::inc is now obsolete, remove the calls |
274 | #local @INC = CPANPLUS::inc->original_inc; |
275 | |
276 | for my $dir (@INC ) { |
277 | next if $dir eq '.'; |
278 | |
279 | ### not a directory after all ### |
280 | next unless -d $dir; |
281 | |
282 | ### make sure to clean up the directories just in case, |
283 | ### as we're making assumptions about the length |
284 | ### This solves rt.cpan issue #19738 |
285 | $dir = File::Spec->canonpath( $dir ); |
286 | |
287 | File::Find::find( |
288 | { %find_args, |
289 | wanted => sub { |
290 | |
291 | return unless /\.pm$/i; |
292 | my $mod = $File::Find::name; |
293 | |
294 | $mod = substr($mod, length($dir) + 1, -3); |
295 | $mod = join '::', File::Spec->splitdir($mod); |
296 | |
297 | return if $seen{$mod}++; |
298 | my $modobj = $self->module_tree($mod) or return; |
299 | |
300 | push @rv, $modobj; |
301 | }, |
302 | }, $dir |
303 | ); |
304 | } |
305 | |
306 | return \@rv; |
307 | } |
308 | |
309 | 1; |
310 | |
311 | # Local variables: |
312 | # c-indentation-style: bsd |
313 | # c-basic-offset: 4 |
314 | # indent-tabs-mode: nil |
315 | # End: |
316 | # vim: expandtab shiftwidth=4: |