File Coverage

lib/CPANPLUS/Internals/Search.pm
Criterion Covered Total %
statement 73 73 100.0
branch 16 20 80.0
condition n/a
subroutine 13 13 100.0
pod n/a
total 102 106 96.2


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Search;
2              
3 15     15   236 use strict;
  15         209  
  15         295  
4              
5 15     15   1582 use CPANPLUS::Error;
  15         204  
  15         278  
6 15     15   281 use CPANPLUS::Internals::Constants;
  15         139  
  15         228  
7 15     15   2810 use CPANPLUS::Module;
  15         174  
  15         462  
8 15     15   411 use CPANPLUS::Module::Author;
  15         156  
  15         379  
9              
10 15     15   228 use File::Find;
  15         162  
  15         311  
11 15     15   247 use File::Spec;
  15         181  
  15         298  
12              
13 15     15   227 use Params::Check qw[check allow];
  15         142  
  15         307  
14 15     15   290 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         144  
  15         414  
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 18     18   873     my $self = shift;
141 18         483     my $conf = $self->configure_object;
142 18         589     my %hash = @_;
143              
144 18         155     my($mods,$list,$verbose,$type);
145 18         564     my $tmpl = {
146 18         425         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 18 50       915     my $args = check( $tmpl, \%hash ) or return;
157              
158 18         246     { local $Params::Check::VERBOSE = 0;
  18         242  
159              
160 18         276         my @rv;
161 18         394         for my $mod (@$mods) {
162             #push @rv, $mod if check(
163             # { $type => { allow => $list } },
164             # { $type => $mod->$type() }
165             # );
166 162 100       2288             push @rv, $mod if allow( $mod->$type() => $list );
167              
168                     }
169 18         564         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 4     4   38     my $self = shift;
212 4         50     my $conf = $self->configure_object;
213 4         48     my %hash = @_;
214              
215 4         34     my($authors,$list,$verbose,$type);
216 4         67     my $tmpl = {
217 4         37         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 4 50       66     my $args = check( $tmpl, \%hash ) or return;
228              
229 4         37     { local $Params::Check::VERBOSE = 0;
  4         36  
230              
231 4         33         my @rv;
232 4         66         for my $auth (@$authors) {
233             #push @rv, $auth if check(
234             # { $type => { allow => $list } },
235             # { $type => $auth->$type }
236             # );
237 32 100       450             push @rv, $auth if allow( $auth->$type() => $list );
238                     }
239 4         104         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 2     2   19     my $self = shift;
256 2         80     my $conf = $self->configure_object;
257 2         19     my %hash = @_;
258              
259 2         18     my %seen; my @rv;
  2         103  
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 2         21     my %find_args = ();
267 2 50       52     $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 2         42     for my $dir (@INC ) {
277 22 100       2726         next if $dir eq '.';
278              
279             ### not a directory after all ###
280 20 50       567         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 20         349         $dir = File::Spec->canonpath( $dir );
286              
287                     File::Find::find(
288                         { %find_args,
289                             wanted => sub {
290              
291 36958 100   36958   30895549                     return unless /\.pm$/i;
292 16554         220293                     my $mod = $File::Find::name;
293              
294 16554         238695                     $mod = substr($mod, length($dir) + 1, -3);
295 16554         311608                     $mod = join '::', File::Spec->splitdir($mod);
296              
297 16554 100       530280                     return if $seen{$mod}++;
298 16376 100       273272                     my $modobj = $self->module_tree($mod) or return;
299              
300 8         109                     push @rv, $modobj;
301                             },
302 20         1690             }, $dir
303                     );
304                 }
305              
306 2         5531     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:
317