File Coverage

lib/CPANPLUS/Internals/Search.pm
Criterion Covered Total %
statement 74 84 88.1
branch 14 24 58.3
condition n/a
subroutine 14 14 100.0
pod n/a
total 102 122 83.6


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