367 lines
12 KiB
Perl
367 lines
12 KiB
Perl
package CPANPLUS::Internals::Search;
|
|
|
|
use strict;
|
|
|
|
use CPANPLUS::Error;
|
|
use CPANPLUS::Internals::Constants;
|
|
use CPANPLUS::Module;
|
|
use CPANPLUS::Module::Author;
|
|
|
|
use File::Find;
|
|
use File::Spec;
|
|
|
|
use Params::Check qw[check allow];
|
|
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
|
|
|
use vars qw[$VERSION];
|
|
$VERSION = "0.9910";
|
|
|
|
$Params::Check::VERBOSE = 1;
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
CPANPLUS::Internals::Search - internals for searching for modules
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
my $aref = $cpan->_search_module_tree(
|
|
type => 'package',
|
|
allow => [qr/DBI/],
|
|
);
|
|
|
|
my $aref = $cpan->_search_author_tree(
|
|
type => 'cpanid',
|
|
data => \@old_results,
|
|
verbose => 1,
|
|
allow => [qw|KANE AUTRIJUS|],
|
|
);
|
|
|
|
my $aref = $cpan->_all_installed( );
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
The functions in this module are designed to find module(objects)
|
|
based on certain criteria and return them.
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 _search_module_tree( type => TYPE, allow => \@regexes, [data => \@previous_results ] )
|
|
|
|
Searches the moduletree for module objects matching the criteria you
|
|
specify. Returns an array ref of module objects on success, and false
|
|
on failure.
|
|
|
|
It takes the following arguments:
|
|
|
|
=over 4
|
|
|
|
=item type
|
|
|
|
This can be any of the accessors for the C<CPANPLUS::Module> objects.
|
|
This is a required argument.
|
|
|
|
=item allow
|
|
|
|
A set of rules, or more precisely, a list of regexes (via C<qr//> or
|
|
plain strings), that the C<type> must adhere too. You can specify as
|
|
many as you like, and it will be treated as an C<OR> search.
|
|
For an C<AND> search, see the C<data> argument.
|
|
|
|
This is a required argument.
|
|
|
|
=item data
|
|
|
|
An arrayref of previous search results. This is the way to do an C<AND>
|
|
search -- C<_search_module_tree> will only search the module objects
|
|
specified in C<data> if provided, rather than the moduletree itself.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
# Although the Params::Check solution is more graceful, it is WAY too slow.
|
|
#
|
|
# This sample script:
|
|
#
|
|
# use CPANPLUS::Backend;
|
|
# my $cb = new CPANPLUS::Backend;
|
|
# $cb->module_tree;
|
|
# my @list = $cb->search( type => 'module', allow => [qr/^Acme/] );
|
|
# print $_->module, $/ for @list;
|
|
#
|
|
# Produced the following output using Dprof WITH params::check code
|
|
#
|
|
# Total Elapsed Time = 3.670024 Seconds
|
|
# User+System Time = 3.390373 Seconds
|
|
# Exclusive Times
|
|
# %Time ExclSec CumulS #Calls sec/call Csec/c Name
|
|
# 88.7 3.008 4.463 20610 0.0001 0.0002 Params::Check::check
|
|
# 47.4 1.610 1.610 1 1.6100 1.6100 Storable::net_pstore
|
|
# 25.6 0.869 0.737 20491 0.0000 0.0000 Locale::Maketext::Simple::_default
|
|
# _gettext
|
|
# 23.2 0.789 0.524 40976 0.0000 0.0000 Params::Check::_who_was_it
|
|
# 23.2 0.789 0.677 20610 0.0000 0.0000 Params::Check::_sanity_check
|
|
# 19.7 0.670 0.670 1 0.6700 0.6700 Storable::pretrieve
|
|
# 14.1 0.480 0.211 41350 0.0000 0.0000 Params::Check::_convert_case
|
|
# 11.5 0.390 0.256 20610 0.0000 0.0000 Params::Check::_hashdefs
|
|
# 11.5 0.390 0.255 20697 0.0000 0.0000 Params::Check::_listreqs
|
|
# 11.4 0.389 0.177 20653 0.0000 0.0000 Params::Check::_canon_key
|
|
# 10.9 0.370 0.356 20697 0.0000 0.0000 Params::Check::_hasreq
|
|
# 8.02 0.272 4.750 1 0.2723 4.7501 CPANPLUS::Internals::Search::_sear
|
|
# ch_module_tree
|
|
# 6.49 0.220 0.086 20653 0.0000 0.0000 Params::Check::_iskey
|
|
# 6.19 0.210 0.077 20488 0.0000 0.0000 Params::Check::_store_error
|
|
# 5.01 0.170 0.036 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__
|
|
#
|
|
# and this output /without/
|
|
#
|
|
# Total Elapsed Time = 2.803426 Seconds
|
|
# User+System Time = 2.493426 Seconds
|
|
# Exclusive Times
|
|
# %Time ExclSec CumulS #Calls sec/call Csec/c Name
|
|
# 56.9 1.420 1.420 1 1.4200 1.4200 Storable::net_pstore
|
|
# 25.6 0.640 0.640 1 0.6400 0.6400 Storable::pretrieve
|
|
# 9.22 0.230 0.096 20680 0.0000 0.0000 CPANPLUS::Module::__ANON__
|
|
# 7.06 0.176 0.272 1 0.1762 0.2719 CPANPLUS::Internals::Search::_sear
|
|
# ch_module_tree
|
|
# 3.21 0.080 0.098 10 0.0080 0.0098 IPC::Cmd::BEGIN
|
|
# 1.60 0.040 0.205 13 0.0031 0.0158 CPANPLUS::Internals::BEGIN
|
|
# 1.20 0.030 0.030 29 0.0010 0.0010 vars::BEGIN
|
|
# 1.20 0.030 0.117 10 0.0030 0.0117 Log::Message::BEGIN
|
|
# 1.20 0.030 0.029 9 0.0033 0.0033 CPANPLUS::Internals::Search::BEGIN
|
|
# 0.80 0.020 0.020 5 0.0040 0.0040 DynaLoader::dl_load_file
|
|
# 0.80 0.020 0.127 10 0.0020 0.0127 CPANPLUS::Module::BEGIN
|
|
# 0.80 0.020 0.389 2 0.0099 0.1944 main::BEGIN
|
|
# 0.80 0.020 0.359 12 0.0017 0.0299 CPANPLUS::Backend::BEGIN
|
|
# 0.40 0.010 0.010 30 0.0003 0.0003 Config::FETCH
|
|
# 0.40 0.010 0.010 18 0.0006 0.0005 Locale::Maketext::Simple::load_loc
|
|
#
|
|
|
|
sub _search_module_tree {
|
|
|
|
my $self = shift;
|
|
my $conf = $self->configure_object;
|
|
my %hash = @_;
|
|
|
|
my($mods,$list,$verbose,$type);
|
|
my $tmpl = {
|
|
data => { default => [],
|
|
strict_type=> 1, store => \$mods },
|
|
allow => { required => 1, default => [ ], strict_type => 1,
|
|
store => \$list },
|
|
verbose => { default => $conf->get_conf('verbose'),
|
|
store => \$verbose },
|
|
type => { required => 1, allow => [CPANPLUS::Module->accessors()],
|
|
store => \$type },
|
|
};
|
|
|
|
my $args = do {
|
|
### don't check the template for sanity
|
|
### -- we know it's good and saves a lot of performance
|
|
local $Params::Check::SANITY_CHECK_TEMPLATE = 0;
|
|
|
|
check( $tmpl, \%hash );
|
|
} or return;
|
|
|
|
### a list of module objects was supplied
|
|
if( @$mods ) {
|
|
local $Params::Check::VERBOSE = 0;
|
|
|
|
my @rv;
|
|
for my $mod (@$mods) {
|
|
#push @rv, $mod if check(
|
|
# { $type => { allow => $list } },
|
|
# { $type => $mod->$type() }
|
|
# );
|
|
push @rv, $mod if allow( $mod->$type() => $list );
|
|
|
|
}
|
|
return \@rv;
|
|
|
|
} else {
|
|
my @rv = $self->_source_search_module_tree(
|
|
allow => $list,
|
|
type => $type,
|
|
);
|
|
return \@rv;
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 _search_author_tree( type => TYPE, allow => \@regexex, [data => \@previous_results ] )
|
|
|
|
Searches the authortree for author objects matching the criteria you
|
|
specify. Returns an array ref of author objects on success, and false
|
|
on failure.
|
|
|
|
It takes the following arguments:
|
|
|
|
=over 4
|
|
|
|
=item type
|
|
|
|
This can be any of the accessors for the C<CPANPLUS::Module::Author>
|
|
objects. This is a required argument.
|
|
|
|
=item allow
|
|
|
|
|
|
A set of rules, or more precisely, a list of regexes (via C<qr//> or
|
|
plain strings), that the C<type> must adhere too. You can specify as
|
|
many as you like, and it will be treated as an C<OR> search.
|
|
For an C<AND> search, see the C<data> argument.
|
|
|
|
This is a required argument.
|
|
|
|
=item data
|
|
|
|
An arrayref of previous search results. This is the way to do an C<and>
|
|
search -- C<_search_author_tree> will only search the author objects
|
|
specified in C<data> if provided, rather than the authortree itself.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub _search_author_tree {
|
|
my $self = shift;
|
|
my $conf = $self->configure_object;
|
|
my %hash = @_;
|
|
|
|
my($authors,$list,$verbose,$type);
|
|
my $tmpl = {
|
|
data => { default => [],
|
|
strict_type=> 1, store => \$authors },
|
|
allow => { required => 1, default => [ ], strict_type => 1,
|
|
store => \$list },
|
|
verbose => { default => $conf->get_conf('verbose'),
|
|
store => \$verbose },
|
|
type => { required => 1, allow => [CPANPLUS::Module::Author->accessors()],
|
|
store => \$type },
|
|
};
|
|
|
|
my $args = check( $tmpl, \%hash ) or return;
|
|
|
|
if( @$authors ) {
|
|
local $Params::Check::VERBOSE = 0;
|
|
|
|
my @rv;
|
|
for my $auth (@$authors) {
|
|
#push @rv, $auth if check(
|
|
# { $type => { allow => $list } },
|
|
# { $type => $auth->$type }
|
|
# );
|
|
push @rv, $auth if allow( $auth->$type() => $list );
|
|
}
|
|
return \@rv;
|
|
} else {
|
|
my @rv = $self->_source_search_author_tree(
|
|
allow => $list,
|
|
type => $type,
|
|
);
|
|
return \@rv;
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 _all_installed()
|
|
|
|
This function returns an array ref of module objects of modules that
|
|
are installed on this system.
|
|
|
|
=cut
|
|
|
|
sub _all_installed {
|
|
my $self = shift;
|
|
my $conf = $self->configure_object;
|
|
my %hash = @_;
|
|
|
|
### File::Find uses follow_skip => 1 by default, which doesn't die
|
|
### on duplicates, unless they are directories or symlinks.
|
|
### Ticket #29796 shows this code dying on Alien::WxWidgets,
|
|
### which uses symlinks.
|
|
### File::Find doc says to use follow_skip => 2 to ignore duplicates
|
|
### so this will stop it from dying.
|
|
my %find_args = ( follow_skip => 2 );
|
|
|
|
### File::Find uses lstat, which quietly becomes stat on win32
|
|
### it then uses -l _ which is not allowed by the statbuffer because
|
|
### you did a stat, not an lstat (duh!). so don't tell win32 to
|
|
### follow symlinks, as that will break badly
|
|
$find_args{'follow_fast'} = 1 unless ON_WIN32;
|
|
|
|
### never use the @INC hooks to find installed versions of
|
|
### modules -- they're just there in case they're not on the
|
|
### perl install, but the user shouldn't trust them for *other*
|
|
### modules!
|
|
### XXX CPANPLUS::inc is now obsolete, remove the calls
|
|
#local @INC = CPANPLUS::inc->original_inc;
|
|
|
|
my %seen; my @rv;
|
|
for my $dir (@INC ) {
|
|
next if $dir eq '.';
|
|
|
|
### not a directory after all
|
|
### may be coderef or some such
|
|
next unless -d $dir;
|
|
|
|
### make sure to clean up the directories just in case,
|
|
### as we're making assumptions about the length
|
|
### This solves rt.cpan issue #19738
|
|
|
|
### John M. notes: On VMS cannonpath can not currently handle
|
|
### the $dir values that are in UNIX format.
|
|
$dir = File::Spec->canonpath( $dir ) unless ON_VMS;
|
|
|
|
### have to use F::S::Unix on VMS, or things will break
|
|
my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec';
|
|
|
|
### XXX in some cases File::Find can actually die!
|
|
### so be safe and wrap it in an eval.
|
|
eval { File::Find::find(
|
|
{ %find_args,
|
|
wanted => sub {
|
|
|
|
return unless /\.pm$/i;
|
|
my $mod = $File::Find::name;
|
|
|
|
### make sure it's in Unix format, as it
|
|
### may be in VMS format on VMS;
|
|
$mod = VMS::Filespec::unixify( $mod ) if ON_VMS;
|
|
|
|
$mod = substr($mod, length($dir) + 1, -3);
|
|
$mod = join '::', $file_spec->splitdir($mod);
|
|
|
|
return if $seen{$mod}++;
|
|
|
|
my $modobj = $self->module_tree($mod);
|
|
|
|
### separate return, a list context return with one ''
|
|
### in it, is also true!
|
|
return unless $modobj;
|
|
|
|
push @rv, $modobj;
|
|
},
|
|
}, $dir
|
|
) };
|
|
|
|
### report the error if file::find died
|
|
error(loc("Error finding installed files in '%1': %2", $dir, $@)) if $@;
|
|
}
|
|
|
|
return \@rv;
|
|
}
|
|
|
|
1;
|
|
|
|
# Local variables:
|
|
# c-indentation-style: bsd
|
|
# c-basic-offset: 4
|
|
# indent-tabs-mode: nil
|
|
# End:
|
|
# vim: expandtab shiftwidth=4:
|