lib/CPANPLUS/Internals/Search.pm

   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: