[Summary view] [Print] [Text view]

   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      ### File::Find uses follow_skip => 1 by default, which doesn't die
 260      ### on duplicates, unless they are directories or symlinks.
 261      ### Ticket #29796 shows this code dying on Alien::WxWidgets,
 262      ### which uses symlinks.
 263      ### File::Find doc says to use follow_skip => 2 to ignore duplicates
 264      ### so this will stop it from dying.
 265      my %find_args = ( follow_skip => 2 );
 266  
 267      ### File::Find uses lstat, which quietly becomes stat on win32
 268      ### it then uses -l _ which is not allowed by the statbuffer because
 269      ### you did a stat, not an lstat (duh!). so don't tell win32 to
 270      ### follow symlinks, as that will break badly
 271      $find_args{'follow_fast'} = 1 unless ON_WIN32;
 272  
 273      ### never use the @INC hooks to find installed versions of
 274      ### modules -- they're just there in case they're not on the
 275      ### perl install, but the user shouldn't trust them for *other*
 276      ### modules!
 277      ### XXX CPANPLUS::inc is now obsolete, remove the calls
 278      #local @INC = CPANPLUS::inc->original_inc;
 279  
 280      my %seen; my @rv;
 281      for my $dir (@INC ) {
 282          next if $dir eq '.';
 283  
 284          ### not a directory after all 
 285          ### may be coderef or some such
 286          next unless -d $dir;
 287  
 288          ### make sure to clean up the directories just in case,
 289          ### as we're making assumptions about the length
 290          ### This solves rt.cpan issue #19738
 291          
 292          ### John M. notes: On VMS cannonpath can not currently handle 
 293          ### the $dir values that are in UNIX format.
 294          $dir = File::Spec->canonpath( $dir ) unless ON_VMS;
 295          
 296          ### have to use F::S::Unix on VMS, or things will break
 297          my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec';
 298  
 299          ### XXX in some cases File::Find can actually die!
 300          ### so be safe and wrap it in an eval.
 301          eval { File::Find::find(
 302              {   %find_args,
 303                  wanted      => sub {
 304  
 305                      return unless /\.pm$/i;
 306                      my $mod = $File::Find::name;
 307  
 308                      ### make sure it's in Unix format, as it
 309                      ### may be in VMS format on VMS;
 310                      $mod = VMS::Filespec::unixify( $mod ) if ON_VMS;                    
 311                      
 312                      $mod = substr($mod, length($dir) + 1, -3);
 313                      $mod = join '::', $file_spec->splitdir($mod);
 314  
 315                      return if $seen{$mod}++;
 316  
 317                      my $modobj = $self->module_tree($mod);
 318                      
 319                      ### seperate return, a list context return with one ''
 320                      ### in it, is also true!
 321                      return unless $modobj;
 322  
 323                      push @rv, $modobj;
 324                  },
 325              }, $dir
 326          ) };
 327  
 328          ### report the error if file::find died
 329          error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@;
 330      }
 331  
 332      return \@rv;
 333  }
 334  
 335  1;
 336  
 337  # Local variables:
 338  # c-indentation-style: bsd
 339  # c-basic-offset: 4
 340  # indent-tabs-mode: nil
 341  # End:
 342  # vim: expandtab shiftwidth=4: