ext/CPANPLUS/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 => \@regexes, [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
 141     my $self = shift;
 142     my $conf = $self->configure_object;
 143     my %hash = @_;
 144
 145     my($mods,$list,$verbose,$type);
 146     my $tmpl = {
 147         data    => { default    => [],
 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
 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;
 161
 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;
 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;
 179
 180     } else {
 181         my @rv = $self->_source_search_module_tree(
 182             allow   => $list,
 183             type    => $type,
 184         );
 185         return \@rv;
 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 = {
 233         data    => { default    => [],
 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
 245     if( @$authors ) {
 246         local $Params::Check::VERBOSE = 0;
 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;
 257     } else {
 258         my @rv = $self->_source_search_author_tree(
 259             allow   => $list,
 260             type    => $type,
 261         );
 262         return \@rv;
 263     }
 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
 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 );
 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
 292     $find_args{'follow_fast'} = 1 unless ON_WIN32;
 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
 301     my %seen; my @rv;
 302     for my $dir (@INC ) {
 303         next if $dir eq '.';
 304
 305         ### not a directory after all
 306         ### may be coderef or some such
 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
 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(
 323             {   %find_args,
 324                 wanted      => sub {
 325
 326                     return unless /\.pm$/i;
 327                     my $mod = $File::Find::name;
 328
 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
 333                     $mod = substr($mod, length($dir) + 1, -3);
 334                     $mod = join '::', $file_spec->splitdir($mod);
 335
 336                     return if $seen{$mod}++;
 337
 338                     my $modobj = $self->module_tree($mod);
 339
 340                     ### seperate return, a list context return with one ''
 341                     ### in it, is also true!
 342                     return unless $modobj;
 343
 344                     push @rv, $modobj;
 345                 },
 346             }, $dir
 347         ) };
 348
 349         ### report the error if file::find died
 350         error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@;
 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: