1353 lines
40 KiB
Perl
1353 lines
40 KiB
Perl
package CPANPLUS::Backend;
|
|
|
|
use strict;
|
|
|
|
|
|
use CPANPLUS::Error;
|
|
use CPANPLUS::Configure;
|
|
use CPANPLUS::Internals;
|
|
use CPANPLUS::Internals::Constants;
|
|
use CPANPLUS::Module;
|
|
use CPANPLUS::Module::Author;
|
|
use CPANPLUS::Backend::RV;
|
|
|
|
use FileHandle;
|
|
use File::Spec ();
|
|
use File::Spec::Unix ();
|
|
use File::Basename ();
|
|
use Params::Check qw[check];
|
|
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
|
|
|
$Params::Check::VERBOSE = 1;
|
|
|
|
use vars qw[@ISA $VERSION];
|
|
|
|
@ISA = qw[CPANPLUS::Internals];
|
|
$VERSION = "0.9910";
|
|
|
|
### mark that we're running under CPANPLUS to spawned processes
|
|
$ENV{'PERL5_CPANPLUS_IS_RUNNING'} = $$;
|
|
|
|
### XXX version.pm MAY format this version, if it's in use... :(
|
|
### so for consistency, just call ->VERSION ourselves as well.
|
|
$ENV{'PERL5_CPANPLUS_IS_VERSION'} = __PACKAGE__->VERSION;
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
CPANPLUS::Backend - programmer's interface to CPANPLUS
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
my $cb = CPANPLUS::Backend->new;
|
|
my $conf = $cb->configure_object;
|
|
|
|
my $author = $cb->author_tree('KANE');
|
|
my $mod = $cb->module_tree('Some::Module');
|
|
my $mod = $cb->parse_module( module => 'Some::Module' );
|
|
|
|
my @objs = $cb->search( type => TYPE,
|
|
allow => [...] );
|
|
|
|
$cb->flush('all');
|
|
$cb->reload_indices;
|
|
$cb->local_mirror;
|
|
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module provides the programmer's interface to the C<CPANPLUS>
|
|
libraries.
|
|
|
|
=head1 ENVIRONMENT
|
|
|
|
When C<CPANPLUS::Backend> is loaded, which is necessary for just
|
|
about every <CPANPLUS> operation, the environment variable
|
|
C<PERL5_CPANPLUS_IS_RUNNING> is set to the current process id.
|
|
|
|
Additionally, the environment variable C<PERL5_CPANPLUS_IS_VERSION>
|
|
will be set to the version of C<CPANPLUS::Backend>.
|
|
|
|
This information might be useful somehow to spawned processes.
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 $cb = CPANPLUS::Backend->new( [CONFIGURE_OBJ] )
|
|
|
|
This method returns a new C<CPANPLUS::Backend> object.
|
|
This also initialises the config corresponding to this object.
|
|
You have two choices in this:
|
|
|
|
=over 4
|
|
|
|
=item Provide a valid C<CPANPLUS::Configure> object
|
|
|
|
This will be used verbatim.
|
|
|
|
=item No arguments
|
|
|
|
Your default config will be loaded and used.
|
|
|
|
=back
|
|
|
|
New will return a C<CPANPLUS::Backend> object on success and die on
|
|
failure.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $conf;
|
|
|
|
if( $_[0] && IS_CONFOBJ->( conf => $_[0] ) ) {
|
|
$conf = shift;
|
|
} else {
|
|
$conf = CPANPLUS::Configure->new() or return;
|
|
}
|
|
|
|
my $self = $class->SUPER::_init( _conf => $conf );
|
|
|
|
return $self;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $href = $cb->module_tree( [@modules_names_list] )
|
|
|
|
Returns a reference to the CPANPLUS module tree.
|
|
|
|
If you give it any arguments, they will be treated as module names
|
|
and C<module_tree> will try to look up these module names and
|
|
return the corresponding module objects instead.
|
|
|
|
See L<CPANPLUS::Module> for the operations you can perform on a
|
|
module object.
|
|
|
|
=cut
|
|
|
|
sub module_tree {
|
|
my $self = shift;
|
|
my $modtree = $self->_module_tree;
|
|
|
|
if( @_ ) {
|
|
my @rv;
|
|
for my $name ( grep { defined } @_) {
|
|
|
|
### From John Malmberg: This is failing on VMS
|
|
### because ODS-2 does not retain the case of
|
|
### filenames that are created.
|
|
### The problem is the filename is being converted
|
|
### to a module name and then looked up in the
|
|
### %$modtree hash.
|
|
###
|
|
### As a fix, we do a search on VMS instead --
|
|
### more cpu cycles, but it gets around the case
|
|
### problem --kane
|
|
my ($modobj) = do {
|
|
ON_VMS
|
|
? $self->search(
|
|
type => 'module',
|
|
allow => [qr/^$name$/i],
|
|
)
|
|
: $modtree->{$name}
|
|
};
|
|
|
|
push @rv, $modobj || '';
|
|
}
|
|
return @rv == 1 ? $rv[0] : @rv;
|
|
} else {
|
|
return $modtree;
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $href = $cb->author_tree( [@author_names_list] )
|
|
|
|
Returns a reference to the CPANPLUS author tree.
|
|
|
|
If you give it any arguments, they will be treated as author names
|
|
and C<author_tree> will try to look up these author names and
|
|
return the corresponding author objects instead.
|
|
|
|
See L<CPANPLUS::Module::Author> for the operations you can perform on
|
|
an author object.
|
|
|
|
=cut
|
|
|
|
sub author_tree {
|
|
my $self = shift;
|
|
my $authtree = $self->_author_tree;
|
|
|
|
if( @_ ) {
|
|
my @rv;
|
|
for my $name (@_) {
|
|
push @rv, $authtree->{$name} || '';
|
|
}
|
|
return @rv == 1 ? $rv[0] : @rv;
|
|
} else {
|
|
return $authtree;
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $conf = $cb->configure_object;
|
|
|
|
Returns a copy of the C<CPANPLUS::Configure> object.
|
|
|
|
See L<CPANPLUS::Configure> for operations you can perform on a
|
|
configure object.
|
|
|
|
=cut
|
|
|
|
sub configure_object { return shift->_conf() };
|
|
|
|
=head2 $su = $cb->selfupdate_object;
|
|
|
|
Returns a copy of the C<CPANPLUS::Selfupdate> object.
|
|
|
|
See the L<CPANPLUS::Selfupdate> manpage for the operations
|
|
you can perform on the selfupdate object.
|
|
|
|
=cut
|
|
|
|
sub selfupdate_object { return shift->_selfupdate() };
|
|
|
|
=pod
|
|
|
|
=head2 @mods = $cb->search( type => TYPE, allow => AREF, [data => AREF, verbose => BOOL] )
|
|
|
|
C<search> enables you to search for either module or author objects,
|
|
based on their data. The C<type> you can specify is any of the
|
|
accessors specified in C<CPANPLUS::Module::Author> or
|
|
C<CPANPLUS::Module>. C<search> will determine by the C<type> you
|
|
specified whether to search by author object or module object.
|
|
|
|
You have to specify an array reference of regular expressions or
|
|
strings to match against. The rules used for this array ref are the
|
|
same as in C<Params::Check>, so read that manpage for details.
|
|
|
|
The search is an C<or> search, meaning that if C<any> of the criteria
|
|
match, the search is considered to be successful.
|
|
|
|
You can specify the result of a previous search as C<data> to limit
|
|
the new search to these module or author objects, rather than the
|
|
entire module or author tree. This is how you do C<and> searches.
|
|
|
|
Returns a list of module or author objects on success and false
|
|
on failure.
|
|
|
|
See L<CPANPLUS::Module> for the operations you can perform on a
|
|
module object.
|
|
See L<CPANPLUS::Module::Author> for the operations you can perform on
|
|
an author object.
|
|
|
|
=cut
|
|
|
|
sub search {
|
|
my $self = shift;
|
|
my $conf = $self->configure_object;
|
|
my %hash = @_;
|
|
|
|
my ($type);
|
|
my $args = do {
|
|
local $Params::Check::NO_DUPLICATES = 0;
|
|
local $Params::Check::ALLOW_UNKNOWN = 1;
|
|
|
|
my $tmpl = {
|
|
type => { required => 1, allow => [CPANPLUS::Module->accessors(),
|
|
CPANPLUS::Module::Author->accessors()], store => \$type },
|
|
allow => { required => 1, default => [ ], strict_type => 1 },
|
|
};
|
|
|
|
check( $tmpl, \%hash )
|
|
} or return;
|
|
|
|
### figure out whether it was an author or a module search
|
|
### when ambiguous, it'll be an author search.
|
|
my $aref;
|
|
if( grep { $type eq $_ } CPANPLUS::Module::Author->accessors() ) {
|
|
$aref = $self->_search_author_tree( %$args );
|
|
} else {
|
|
$aref = $self->_search_module_tree( %$args );
|
|
}
|
|
|
|
return @$aref if $aref;
|
|
return;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $backend_rv = $cb->fetch( modules => \@mods )
|
|
|
|
Fetches a list of modules. C<@mods> can be a list of distribution
|
|
names, module names or module objects--basically anything that
|
|
L<parse_module> can understand.
|
|
|
|
See the equivalent method in C<CPANPLUS::Module> for details on
|
|
other options you can pass.
|
|
|
|
Since this is a multi-module method call, the return value is
|
|
implemented as a C<CPANPLUS::Backend::RV> object. Please consult
|
|
that module's documentation on how to interpret the return value.
|
|
|
|
=head2 $backend_rv = $cb->extract( modules => \@mods )
|
|
|
|
Extracts a list of modules. C<@mods> can be a list of distribution
|
|
names, module names or module objects--basically anything that
|
|
L<parse_module> can understand.
|
|
|
|
See the equivalent method in C<CPANPLUS::Module> for details on
|
|
other options you can pass.
|
|
|
|
Since this is a multi-module method call, the return value is
|
|
implemented as a C<CPANPLUS::Backend::RV> object. Please consult
|
|
that module's documentation on how to interpret the return value.
|
|
|
|
=head2 $backend_rv = $cb->install( modules => \@mods )
|
|
|
|
Installs a list of modules. C<@mods> can be a list of distribution
|
|
names, module names or module objects--basically anything that
|
|
L<parse_module> can understand.
|
|
|
|
See the equivalent method in C<CPANPLUS::Module> for details on
|
|
other options you can pass.
|
|
|
|
Since this is a multi-module method call, the return value is
|
|
implemented as a C<CPANPLUS::Backend::RV> object. Please consult
|
|
that module's documentation on how to interpret the return value.
|
|
|
|
=head2 $backend_rv = $cb->readme( modules => \@mods )
|
|
|
|
Fetches the readme for a list of modules. C<@mods> can be a list of
|
|
distribution names, module names or module objects--basically
|
|
anything that L<parse_module> can understand.
|
|
|
|
See the equivalent method in C<CPANPLUS::Module> for details on
|
|
other options you can pass.
|
|
|
|
Since this is a multi-module method call, the return value is
|
|
implemented as a C<CPANPLUS::Backend::RV> object. Please consult
|
|
that module's documentation on how to interpret the return value.
|
|
|
|
=head2 $backend_rv = $cb->files( modules => \@mods )
|
|
|
|
Returns a list of files used by these modules if they are installed.
|
|
C<@mods> can be a list of distribution names, module names or module
|
|
objects--basically anything that L<parse_module> can understand.
|
|
|
|
See the equivalent method in C<CPANPLUS::Module> for details on
|
|
other options you can pass.
|
|
|
|
Since this is a multi-module method call, the return value is
|
|
implemented as a C<CPANPLUS::Backend::RV> object. Please consult
|
|
that module's documentation on how to interpret the return value.
|
|
|
|
=head2 $backend_rv = $cb->distributions( modules => \@mods )
|
|
|
|
Returns a list of module objects representing all releases for this
|
|
module on success.
|
|
C<@mods> can be a list of distribution names, module names or module
|
|
objects, basically anything that L<parse_module> can understand.
|
|
|
|
See the equivalent method in C<CPANPLUS::Module> for details on
|
|
other options you can pass.
|
|
|
|
Since this is a multi-module method call, the return value is
|
|
implemented as a C<CPANPLUS::Backend::RV> object. Please consult
|
|
that module's documentation on how to interpret the return value.
|
|
|
|
=cut
|
|
|
|
### XXX add directory_tree, packlist etc? or maybe remove files? ###
|
|
for my $func (qw[fetch extract install readme files distributions]) {
|
|
no strict 'refs';
|
|
|
|
*$func = sub {
|
|
my $self = shift;
|
|
my $conf = $self->configure_object;
|
|
my %hash = @_;
|
|
|
|
my ($mods);
|
|
my $args = do {
|
|
local $Params::Check::NO_DUPLICATES = 1;
|
|
local $Params::Check::ALLOW_UNKNOWN = 1;
|
|
|
|
my $tmpl = {
|
|
modules => { default => [], strict_type => 1,
|
|
required => 1, store => \$mods },
|
|
};
|
|
|
|
check( $tmpl, \%hash );
|
|
} or return;
|
|
|
|
### make them all into module objects ###
|
|
my %mods = map { $_ => $self->parse_module(module => $_) || '' } @$mods;
|
|
|
|
my $flag; my $href;
|
|
while( my($name,$obj) = each %mods ) {
|
|
$href->{$name} = IS_MODOBJ->( mod => $obj )
|
|
? $obj->$func( %$args )
|
|
: undef;
|
|
|
|
$flag++ unless $href->{$name};
|
|
}
|
|
|
|
return CPANPLUS::Backend::RV->new(
|
|
function => $func,
|
|
ok => ( !$flag ? 1 : 0 ),
|
|
rv => $href,
|
|
args => \%hash,
|
|
);
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $mod_obj = $cb->parse_module( module => $modname|$distname|$modobj|URI|PATH )
|
|
|
|
C<parse_module> tries to find a C<CPANPLUS::Module> object that
|
|
matches your query. Here's a list of examples you could give to
|
|
C<parse_module>;
|
|
|
|
=over 4
|
|
|
|
=item Text::Bastardize
|
|
|
|
=item Text-Bastardize
|
|
|
|
=item Text/Bastardize.pm
|
|
|
|
=item Text-Bastardize-1.06
|
|
|
|
=item AYRNIEU/Text-Bastardize
|
|
|
|
=item AYRNIEU/Text-Bastardize-1.06
|
|
|
|
=item AYRNIEU/Text-Bastardize-1.06.tar.gz
|
|
|
|
=item http://example.com/Text-Bastardize-1.06.tar.gz
|
|
|
|
=item file:///tmp/Text-Bastardize-1.06.tar.gz
|
|
|
|
=item /tmp/Text-Bastardize-1.06
|
|
|
|
=item ./Text-Bastardize-1.06
|
|
|
|
=item .
|
|
|
|
=back
|
|
|
|
These items would all come up with a C<CPANPLUS::Module> object for
|
|
C<Text::Bastardize>. The ones marked explicitly as being version 1.06
|
|
would give back a C<CPANPLUS::Module> object of that version.
|
|
Even if the version on CPAN is currently higher.
|
|
|
|
The last three are examples of PATH resolution. In the first, we supply
|
|
an absolute path to the unwrapped distribution. In the second the
|
|
distribution is relative to the current working directory.
|
|
In the third, we will use the current working directory.
|
|
|
|
If C<parse_module> is unable to actually find the module you are looking
|
|
for in its module tree, but you supplied it with an author, module
|
|
and version part in a distribution name or URI, it will create a fake
|
|
C<CPANPLUS::Module> object for you, that you can use just like the
|
|
real thing.
|
|
|
|
See L<CPANPLUS::Module> for the operations you can perform on a
|
|
module object.
|
|
|
|
If even this fancy guessing doesn't enable C<parse_module> to create
|
|
a fake module object for you to use, it will warn about an error and
|
|
return false.
|
|
|
|
=cut
|
|
|
|
sub parse_module {
|
|
my $self = shift;
|
|
my $conf = $self->configure_object;
|
|
my %hash = @_;
|
|
|
|
my $mod;
|
|
my $tmpl = {
|
|
module => { required => 1, store => \$mod },
|
|
};
|
|
|
|
my $args = check( $tmpl, \%hash ) or return;
|
|
|
|
return $mod if IS_MODOBJ->( module => $mod );
|
|
|
|
### ok, so it's not a module object, but a ref nonetheless?
|
|
### what are you smoking?
|
|
if( ref $mod ) {
|
|
error(loc("Can not parse module string from reference '%1'", $mod ));
|
|
return;
|
|
}
|
|
|
|
### check only for allowed characters in a module name
|
|
unless( $mod =~ /[^\w:]/ ) {
|
|
|
|
### perhaps we can find it in the module tree?
|
|
my $maybe = $self->module_tree($mod);
|
|
return $maybe if IS_MODOBJ->( module => $maybe );
|
|
}
|
|
|
|
### Special case arbitrary file paths such as '.' etc.
|
|
if ( $mod and -d File::Spec->rel2abs($mod) ) {
|
|
my $dir = File::Spec->rel2abs($mod);
|
|
my $parent = File::Spec->rel2abs( File::Spec->catdir( $dir, '..' ) );
|
|
|
|
### fix paths on VMS
|
|
if (ON_VMS) {
|
|
$dir = VMS::Filespec::unixify($dir);
|
|
$parent = VMS::Filespec::unixify($parent);
|
|
}
|
|
|
|
my $dist = $mod = File::Basename::basename($dir);
|
|
$dist .= '-0' unless $dist =~ /\-[0-9._]+$/;
|
|
$dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
|
|
|
|
my $modobj = CPANPLUS::Module::Fake->new(
|
|
module => $mod,
|
|
version => 0,
|
|
package => $dist,
|
|
path => $parent,
|
|
author => CPANPLUS::Module::Author::Fake->new
|
|
);
|
|
|
|
### better guess for the version
|
|
$modobj->version( $modobj->package_version )
|
|
if defined $modobj->package_version;
|
|
|
|
### better guess at module name, if possible
|
|
if ( my $pkgname = $modobj->package_name ) {
|
|
$pkgname =~ s/-/::/g;
|
|
|
|
### no sense replacing it unless we changed something
|
|
$modobj->module( $pkgname )
|
|
if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
|
|
}
|
|
|
|
$modobj->status->fetch( $parent );
|
|
$modobj->status->extract( $dir );
|
|
$modobj->get_installer_type;
|
|
return $modobj;
|
|
}
|
|
|
|
### ok, so it looks like a distribution then?
|
|
my @parts = split '/', $mod;
|
|
my $dist = pop @parts;
|
|
|
|
### ah, it's a URL
|
|
if( $mod =~ m|\w+://.+| ) {
|
|
my $modobj = CPANPLUS::Module::Fake->new(
|
|
module => $dist,
|
|
version => 0,
|
|
package => $dist,
|
|
path => File::Spec::Unix->catdir(
|
|
$conf->_get_mirror('base'),
|
|
UNKNOWN_DL_LOCATION ),
|
|
author => CPANPLUS::Module::Author::Fake->new
|
|
);
|
|
|
|
### set the fetch_from accessor so we know to by pass the
|
|
### usual mirrors
|
|
$modobj->status->_fetch_from( $mod );
|
|
|
|
### better guess for the version
|
|
$modobj->version( $modobj->package_version )
|
|
if defined $modobj->package_version;
|
|
|
|
### better guess at module name, if possible
|
|
if ( my $pkgname = $modobj->package_name ) {
|
|
$pkgname =~ s/-/::/g;
|
|
|
|
### no sense replacing it unless we changed something
|
|
$modobj->module( $pkgname )
|
|
if ($pkgname ne $modobj->package_name) || $pkgname !~ /-/;
|
|
}
|
|
|
|
return $modobj;
|
|
}
|
|
|
|
# Stolen from cpanminus to support 'Module/Install.pm'
|
|
# type input
|
|
if ( ( my $tmpmod = $mod ) =~ s/\.pm$//i ) {
|
|
my ($volume, $dirs, $file) = File::Spec->splitpath( $tmpmod );
|
|
$tmpmod = join '::', grep { $_ } File::Spec->splitdir( $dirs ), $file;
|
|
### perhaps we can find it in the module tree?
|
|
my $maybe = $self->module_tree( $tmpmod );
|
|
return $maybe if IS_MODOBJ->( module => $maybe );
|
|
}
|
|
|
|
### perhaps we can find it's a third party module?
|
|
{ my $modobj = CPANPLUS::Module::Fake->new(
|
|
module => $mod,
|
|
version => 0,
|
|
package => $dist,
|
|
path => File::Spec::Unix->catdir(
|
|
$conf->_get_mirror('base'),
|
|
UNKNOWN_DL_LOCATION ),
|
|
author => CPANPLUS::Module::Author::Fake->new
|
|
);
|
|
if( $modobj->is_third_party ) {
|
|
my $info = $modobj->third_party_information;
|
|
|
|
$modobj->author->author( $info->{author} );
|
|
$modobj->author->email( $info->{author_url} );
|
|
$modobj->description( $info->{url} );
|
|
|
|
return $modobj;
|
|
}
|
|
}
|
|
|
|
unless( $dist ) {
|
|
error( loc("%1 is not a proper distribution name!", $mod) );
|
|
return;
|
|
}
|
|
|
|
### there's wonky uris out there, like this:
|
|
### E/EY/EYCK/Net/Lite/Net-Lite-FTP-0.091
|
|
### compensate for that
|
|
my $author;
|
|
### you probably have an A/AB/ABC/....../Dist.tgz type uri
|
|
if( (defined $parts[0] and length $parts[0] == 1) and
|
|
(defined $parts[1] and length $parts[1] == 2) and
|
|
$parts[2] =~ /^$parts[0]/i and $parts[2] =~ /^$parts[1]/i
|
|
) {
|
|
splice @parts, 0, 2; # remove the first 2 entries from the list
|
|
$author = shift @parts; # this is the actual author name then
|
|
|
|
### we''ll assume a ABC/..../Dist.tgz
|
|
} else {
|
|
$author = shift @parts || '';
|
|
}
|
|
|
|
{
|
|
my $guess = $dist;
|
|
$guess =~ s!-!::!g if $guess;
|
|
my $maybe = $self->module_tree( $guess );
|
|
if ( IS_MODOBJ->( module => $maybe ) ) {
|
|
$dist = $maybe->package;
|
|
}
|
|
}
|
|
|
|
my($pkg, $version, $ext, $full) =
|
|
$self->_split_package_string( package => $dist );
|
|
|
|
### translate a distribution into a module name ###
|
|
my $guess = $pkg;
|
|
$guess =~ s/-/::/g if $guess;
|
|
|
|
my $maybe = $self->module_tree( $guess );
|
|
if( IS_MODOBJ->( module => $maybe ) ) {
|
|
|
|
### maybe you asked for a package instead
|
|
if ( $maybe->package eq $mod ) {
|
|
return $maybe;
|
|
|
|
### perhaps an outdated version instead?
|
|
} elsif ( $version ) {
|
|
my $auth_obj; my $path;
|
|
|
|
### did you give us an author part? ###
|
|
if( $author ) {
|
|
$auth_obj = CPANPLUS::Module::Author::Fake->new(
|
|
_id => $maybe->_id,
|
|
cpanid => uc $author,
|
|
author => uc $author,
|
|
);
|
|
$path = File::Spec::Unix->catdir(
|
|
$conf->_get_mirror('base'),
|
|
substr(uc $author, 0, 1),
|
|
substr(uc $author, 0, 2),
|
|
uc $author,
|
|
@parts, #possible sub dirs
|
|
);
|
|
} else {
|
|
$auth_obj = $maybe->author;
|
|
$path = $maybe->path;
|
|
}
|
|
|
|
if( $maybe->package_name eq $pkg ) {
|
|
|
|
my $modobj = CPANPLUS::Module::Fake->new(
|
|
module => $maybe->module,
|
|
version => $version,
|
|
### no extension? use the extension the original package
|
|
### had instead
|
|
package => do { $ext
|
|
? $full
|
|
: $full .'.'. $maybe->package_extension
|
|
},
|
|
path => $path,
|
|
author => $auth_obj,
|
|
_id => $maybe->_id
|
|
);
|
|
return $modobj;
|
|
|
|
### you asked for a specific version?
|
|
### assume our $maybe is the one you wanted,
|
|
### and fix up the version..
|
|
} else {
|
|
|
|
my $modobj = $maybe->clone;
|
|
$modobj->version( $version );
|
|
$modobj->package(
|
|
$maybe->package_name .'-'.
|
|
$version .'.'.
|
|
$maybe->package_extension
|
|
);
|
|
|
|
### you wanted a specific author, but it's not the one
|
|
### from the module tree? we'll fix it up
|
|
if( $author and $author ne $modobj->author->cpanid ) {
|
|
$modobj->author( $auth_obj );
|
|
$modobj->path( $path );
|
|
}
|
|
|
|
return $modobj;
|
|
}
|
|
|
|
### you didn't care about a version, so just return the object then
|
|
} elsif ( !$version ) {
|
|
return $maybe;
|
|
}
|
|
|
|
### ok, so we can't find it, and it's not an outdated dist either
|
|
### perhaps we can fake one based on the author name and so on
|
|
} elsif ( $author and $version ) {
|
|
|
|
### be extra friendly and pad the .tar.gz suffix where needed
|
|
### it's just a guess of course, but most dists are .tar.gz
|
|
$dist .= '.tar.gz' unless $dist =~ /\.[A-Za-z]+$/;
|
|
|
|
### XXX duplication from above for generating author obj + path...
|
|
my $modobj = CPANPLUS::Module::Fake->new(
|
|
module => $guess,
|
|
version => $version,
|
|
package => $dist,
|
|
author => CPANPLUS::Module::Author::Fake->new(
|
|
author => uc $author,
|
|
cpanid => uc $author,
|
|
_id => $self->_id,
|
|
),
|
|
path => File::Spec::Unix->catdir(
|
|
$conf->_get_mirror('base'),
|
|
substr(uc $author, 0, 1),
|
|
substr(uc $author, 0, 2),
|
|
uc $author,
|
|
@parts, #possible subdirs
|
|
),
|
|
_id => $self->_id,
|
|
);
|
|
|
|
return $modobj;
|
|
|
|
### face it, we have /no/ idea what he or she wants...
|
|
### let's start putting the blame somewhere
|
|
} else {
|
|
|
|
# Lets not give up too easily. There is one last chance
|
|
# http://perlmonks.org/?node_id=805957
|
|
# This should catch edge-cases where the package name
|
|
# is unrelated to the modules it contains.
|
|
|
|
my ($modobj) = grep { $_->package_name eq $mod }
|
|
$self->search( type => 'package', allow => [ qr/^\Q$mod\E/ ], );
|
|
return $modobj if IS_MODOBJ->( module => $modobj );
|
|
|
|
unless( $author ) {
|
|
error( loc( "'%1' does not contain an author part", $mod ) );
|
|
}
|
|
|
|
error( loc( "Cannot find '%1' in the module tree", $mod ) );
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $cb->reload_indices( [update_source => BOOL, verbose => BOOL] );
|
|
|
|
This method reloads the source files.
|
|
|
|
If C<update_source> is set to true, this will fetch new source files
|
|
from your CPAN mirror. Otherwise, C<reload_indices> will do its
|
|
usual cache checking and only update them if they are out of date.
|
|
|
|
By default, C<update_source> will be false.
|
|
|
|
The verbose setting defaults to what you have specified in your
|
|
config file.
|
|
|
|
Returns true on success and false on failure.
|
|
|
|
=cut
|
|
|
|
sub reload_indices {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
my $conf = $self->configure_object;
|
|
|
|
my $tmpl = {
|
|
update_source => { default => 0, allow => [qr/^\d$/] },
|
|
verbose => { default => $conf->get_conf('verbose') },
|
|
};
|
|
|
|
my $args = check( $tmpl, \%hash ) or return;
|
|
|
|
### make a call to the internal _module_tree, so it triggers cache
|
|
### file age
|
|
my $uptodate = $self->_check_trees( %$args );
|
|
|
|
|
|
return 1 if $self->_build_trees(
|
|
uptodate => $uptodate,
|
|
use_stored => 0,
|
|
verbose => $conf->get_conf('verbose'),
|
|
);
|
|
|
|
error( loc( "Error rebuilding source trees!" ) );
|
|
|
|
return;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $cb->flush(CACHE_NAME)
|
|
|
|
This method allows flushing of caches.
|
|
There are several things which can be flushed:
|
|
|
|
=over 4
|
|
|
|
=item * C<methods>
|
|
|
|
The return status of methods which have been attempted, such as
|
|
different ways of fetching files. It is recommended that automatic
|
|
flushing be used instead.
|
|
|
|
=item * C<hosts>
|
|
|
|
The return status of URIs which have been attempted, such as
|
|
different hosts of fetching files. It is recommended that automatic
|
|
flushing be used instead.
|
|
|
|
=item * C<modules>
|
|
|
|
Information about modules such as prerequisites and whether
|
|
installation succeeded, failed, or was not attempted.
|
|
|
|
=item * C<lib>
|
|
|
|
This resets PERL5LIB, which is changed to ensure that while installing
|
|
modules they are in our @INC.
|
|
|
|
=item * C<load>
|
|
|
|
This resets the cache of modules we've attempted to load, but failed.
|
|
This enables you to load them again after a failed load, if they
|
|
somehow have become available.
|
|
|
|
=item * C<all>
|
|
|
|
Flush all of the aforementioned caches.
|
|
|
|
=back
|
|
|
|
Returns true on success and false on failure.
|
|
|
|
=cut
|
|
|
|
sub flush {
|
|
my $self = shift;
|
|
my $type = shift or return;
|
|
|
|
my $cache = {
|
|
methods => [ qw( methods load ) ],
|
|
hosts => [ qw( hosts ) ],
|
|
modules => [ qw( modules lib) ],
|
|
lib => [ qw( lib ) ],
|
|
load => [ qw( load ) ],
|
|
all => [ qw( hosts lib modules methods load ) ],
|
|
};
|
|
|
|
my $aref = $cache->{$type}
|
|
or (
|
|
error( loc("No such cache '%1'", $type) ),
|
|
return
|
|
);
|
|
|
|
return $self->_flush( list => $aref );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 @mods = $cb->installed()
|
|
|
|
Returns a list of module objects of all your installed modules.
|
|
If an error occurs, it will return false.
|
|
|
|
See L<CPANPLUS::Module> for the operations you can perform on a
|
|
module object.
|
|
|
|
=cut
|
|
|
|
sub installed {
|
|
my $self = shift;
|
|
my $aref = $self->_all_installed;
|
|
|
|
return @$aref if $aref;
|
|
return;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $cb->local_mirror([path => '/dir/to/save/to', index_files => BOOL, force => BOOL, verbose => BOOL] )
|
|
|
|
Creates a local mirror of CPAN, of only the most recent sources in a
|
|
location you specify. If you set this location equal to a custom host
|
|
in your C<CPANPLUS::Config> you can use your local mirror to install
|
|
from.
|
|
|
|
It takes the following arguments:
|
|
|
|
=over 4
|
|
|
|
=item path
|
|
|
|
The location where to create the local mirror.
|
|
|
|
=item index_files
|
|
|
|
Enable/disable fetching of index files. You can disable fetching of the
|
|
index files if you don't plan to use the local mirror as your primary
|
|
site, or if you'd like up-to-date index files be fetched from elsewhere.
|
|
|
|
Defaults to true.
|
|
|
|
=item force
|
|
|
|
Forces refetching of packages, even if they are there already.
|
|
|
|
Defaults to whatever setting you have in your C<CPANPLUS::Config>.
|
|
|
|
=item verbose
|
|
|
|
Prints more messages about what its doing.
|
|
|
|
Defaults to whatever setting you have in your C<CPANPLUS::Config>.
|
|
|
|
=back
|
|
|
|
Returns true on success and false on error.
|
|
|
|
=cut
|
|
|
|
sub local_mirror {
|
|
my $self = shift;
|
|
my $conf = $self->configure_object;
|
|
my %hash = @_;
|
|
|
|
my($path, $index, $force, $verbose);
|
|
my $tmpl = {
|
|
path => { default => $conf->get_conf('base'),
|
|
store => \$path },
|
|
index_files => { default => 1, store => \$index },
|
|
force => { default => $conf->get_conf('force'),
|
|
store => \$force },
|
|
verbose => { default => $conf->get_conf('verbose'),
|
|
store => \$verbose },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
unless( -d $path ) {
|
|
$self->_mkdir( dir => $path )
|
|
or( error( loc( "Could not create '%1', giving up", $path ) ),
|
|
return
|
|
);
|
|
} elsif ( ! -w _ ) {
|
|
error( loc( "Could not write to '%1', giving up", $path ) );
|
|
return;
|
|
}
|
|
|
|
my $flag;
|
|
AUTHOR: {
|
|
for my $auth ( sort { $a->cpanid cmp $b->cpanid }
|
|
values %{$self->author_tree}
|
|
) {
|
|
|
|
MODULE: {
|
|
my $i;
|
|
for my $mod ( $auth->modules ) {
|
|
my $fetchdir = File::Spec->catdir( $path, $mod->path );
|
|
|
|
my %opts = (
|
|
verbose => $verbose,
|
|
force => $force,
|
|
fetchdir => $fetchdir,
|
|
);
|
|
|
|
### only do this the for the first module ###
|
|
unless( $i++ ) {
|
|
$mod->_get_checksums_file(
|
|
%opts
|
|
) or (
|
|
error( loc( "Could not fetch %1 file, " .
|
|
"skipping author '%2'",
|
|
CHECKSUMS, $auth->cpanid ) ),
|
|
$flag++, next AUTHOR
|
|
);
|
|
}
|
|
|
|
$mod->fetch( %opts )
|
|
or( error( loc( "Could not fetch '%1'", $mod->module ) ),
|
|
$flag++, next MODULE
|
|
);
|
|
} }
|
|
} }
|
|
|
|
if( $index ) {
|
|
for my $name (qw[auth dslip mod]) {
|
|
$self->_update_source(
|
|
name => $name,
|
|
verbose => $verbose,
|
|
path => $path,
|
|
) or ( $flag++, next );
|
|
}
|
|
}
|
|
|
|
return !$flag;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $file = $cb->autobundle([path => OUTPUT_PATH, force => BOOL, verbose => BOOL])
|
|
|
|
Writes out a snapshot of your current installation in C<CPAN> bundle
|
|
style. This can then be used to install the same modules for a
|
|
different or on a different machine by issuing the following commands:
|
|
|
|
### using the default shell:
|
|
CPAN Terminal> i file://path/to/Snapshot_XXYY.pm
|
|
|
|
### using the API
|
|
$modobj = $cb->parse_module( module => 'file://path/to/Snapshot_XXYY.pm' );
|
|
$modobj->install;
|
|
|
|
It will, by default, write to an 'autobundle' directory under your
|
|
cpanplus home directory, but you can override that by supplying a
|
|
C<path> argument.
|
|
|
|
It will return the location of the output file on success and false on
|
|
failure.
|
|
|
|
=cut
|
|
|
|
sub autobundle {
|
|
my $self = shift;
|
|
my $conf = $self->configure_object;
|
|
my %hash = @_;
|
|
|
|
my($path,$force,$verbose);
|
|
my $tmpl = {
|
|
force => { default => $conf->get_conf('force'), store => \$force },
|
|
verbose => { default => $conf->get_conf('verbose'), store => \$verbose },
|
|
path => { default => File::Spec->catdir(
|
|
$conf->get_conf('base'),
|
|
$self->_perl_version( perl => $^X ),
|
|
$conf->_get_build('distdir'),
|
|
$conf->_get_build('autobundle') ),
|
|
store => \$path },
|
|
};
|
|
|
|
check($tmpl, \%hash) or return;
|
|
|
|
unless( -d $path ) {
|
|
$self->_mkdir( dir => $path )
|
|
or( error(loc("Could not create directory '%1'", $path ) ),
|
|
return
|
|
);
|
|
}
|
|
|
|
my $name; my $file;
|
|
{ ### default filename for the bundle ###
|
|
my($year,$month,$day) = (localtime)[5,4,3];
|
|
$year += 1900; $month++;
|
|
|
|
my $ext = 0;
|
|
|
|
my $prefix = $conf->_get_build('autobundle_prefix');
|
|
my $format = "${prefix}_%04d_%02d_%02d_%02d";
|
|
|
|
BLOCK: {
|
|
$name = sprintf( $format, $year, $month, $day, $ext);
|
|
|
|
$file = File::Spec->catfile( $path, $name . '.pm' );
|
|
|
|
-f $file ? ++$ext && redo BLOCK : last BLOCK;
|
|
}
|
|
}
|
|
my $fh;
|
|
unless( $fh = FileHandle->new( ">$file" ) ) {
|
|
error( loc( "Could not open '%1' for writing: %2", $file, $! ) );
|
|
return;
|
|
}
|
|
|
|
### make sure we load the module tree *before* doing this, as it
|
|
### starts to chdir all over the place
|
|
$self->module_tree;
|
|
|
|
my $string = join "\n\n",
|
|
map {
|
|
join ' ',
|
|
$_->module,
|
|
($_->installed_version(verbose => 0) || 'undef')
|
|
} sort {
|
|
$a->module cmp $b->module
|
|
} $self->installed;
|
|
|
|
my $now = scalar localtime;
|
|
my $head = '=head1';
|
|
my $pkg = __PACKAGE__;
|
|
my $version = $self->VERSION;
|
|
my $perl_v = join '', `$^X -V`;
|
|
|
|
print $fh <<EOF;
|
|
package $name;
|
|
|
|
\$VERSION = "0.9910";
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
$head NAME
|
|
|
|
$name - Snapshot of your installation at $now
|
|
|
|
$head SYNOPSIS
|
|
|
|
To install the modules from this snapshot, run:
|
|
|
|
cpanp -i file://full/path/to/${name}.pm
|
|
|
|
$head CONTENTS
|
|
|
|
$string
|
|
|
|
$head CONFIGURATION
|
|
|
|
$perl_v
|
|
|
|
$head AUTHOR
|
|
|
|
This bundle has been generated automatically by
|
|
$pkg $version
|
|
|
|
EOF
|
|
|
|
close $fh;
|
|
|
|
return $file;
|
|
}
|
|
|
|
=head2 $bool = $cb->save_state
|
|
|
|
Explicit command to save memory state to disk. This can be used to save
|
|
information to disk about where a module was extracted, the result of
|
|
C<make test>, etc. This will then be re-loaded into memory when a new
|
|
session starts.
|
|
|
|
The capability of saving state to disk depends on the source engine
|
|
being used (See C<CPANPLUS::Config> for the option to choose your
|
|
source engine). The default storage engine supports this option.
|
|
|
|
Most users will not need this command, but it can handy for automated
|
|
systems like setting up CPAN smoke testers.
|
|
|
|
The method will return true if it managed to save the state to disk,
|
|
or false if it did not.
|
|
|
|
=cut
|
|
|
|
sub save_state {
|
|
my $self = shift;
|
|
return $self->_save_state( @_ );
|
|
}
|
|
|
|
|
|
### XXX these wrappers are not individually tested! only the underlying
|
|
### code through source.t and indirectly through he CustomSource plugin.
|
|
|
|
=pod
|
|
|
|
=head1 CUSTOM MODULE SOURCES
|
|
|
|
Besides the sources as provided by the general C<CPAN> mirrors, it's
|
|
possible to add your own sources list to your C<CPANPLUS> index.
|
|
|
|
The methodology behind this works much like C<Debian's apt-sources>.
|
|
|
|
The methods below show you how to make use of this functionality. Also
|
|
note that most of these methods are available through the default shell
|
|
plugin command C</cs>, making them available as shortcuts through the
|
|
shell and via the command line.
|
|
|
|
=head2 %files = $cb->list_custom_sources
|
|
|
|
Returns a mapping of registered custom sources and their local indices
|
|
as follows:
|
|
|
|
/full/path/to/local/index => http://remote/source
|
|
|
|
Note that any file starting with an C<#> is being ignored.
|
|
|
|
=cut
|
|
|
|
sub list_custom_sources {
|
|
return shift->__list_custom_module_sources( @_ );
|
|
}
|
|
|
|
=head2 $local_index = $cb->add_custom_source( uri => URI, [verbose => BOOL] );
|
|
|
|
Adds an C<URI> to your own sources list and mirrors its index. See the
|
|
documentation on C<< $cb->update_custom_source >> on how this is done.
|
|
|
|
Returns the full path to the local index on success, or false on failure.
|
|
|
|
Note that when adding a new C<URI>, the change to the in-memory tree is
|
|
not saved until you rebuild or save the tree to disk again. You can do
|
|
this using the C<< $cb->reload_indices >> method.
|
|
|
|
=cut
|
|
|
|
sub add_custom_source {
|
|
return shift->_add_custom_module_source( @_ );
|
|
}
|
|
|
|
=head2 $local_index = $cb->remove_custom_source( uri => URI, [verbose => BOOL] );
|
|
|
|
Removes an C<URI> from your own sources list and removes its index.
|
|
|
|
To find out what C<URI>s you have as part of your own sources list, use
|
|
the C<< $cb->list_custom_sources >> method.
|
|
|
|
Returns the full path to the deleted local index file on success, or false
|
|
on failure.
|
|
|
|
=cut
|
|
|
|
### XXX do clever dispatching based on arg number?
|
|
sub remove_custom_source {
|
|
return shift->_remove_custom_module_source( @_ );
|
|
}
|
|
|
|
=head2 $bool = $cb->update_custom_source( [remote => URI] );
|
|
|
|
Updates the indexes for all your custom sources. It does this by fetching
|
|
a file called C<packages.txt> in the root of the custom sources' C<URI>.
|
|
If you provide the C<remote> argument, it will only update the index for
|
|
that specific C<URI>.
|
|
|
|
Here's an example of how custom sources would resolve into index files:
|
|
|
|
file:///path/to/sources => file:///path/to/sources/packages.txt
|
|
http://example.com/sources => http://example.com/sources/packages.txt
|
|
ftp://example.com/sources => ftp://example.com/sources/packages.txt
|
|
|
|
The file C<packages.txt> simply holds a list of packages that can be found
|
|
under the root of the C<URI>. This file can be automatically generated for
|
|
you when the remote source is a C<file:// URI>. For C<http://>, C<ftp://>,
|
|
and similar, the administrator of that repository should run the method
|
|
C<< $cb->write_custom_source_index >> on the repository to allow remote
|
|
users to index it.
|
|
|
|
For details, see the C<< $cb->write_custom_source_index >> method below.
|
|
|
|
All packages that are added via this mechanism will be attributed to the
|
|
author with C<CPANID> C<LOCAL>. You can use this id to search for all
|
|
added packages.
|
|
|
|
=cut
|
|
|
|
sub update_custom_source {
|
|
my $self = shift;
|
|
|
|
### if it mentions /remote/, the request is to update a single uri,
|
|
### not all the ones we have, so dispatch appropriately
|
|
my $rv = grep( /remote/i, @_)
|
|
? $self->__update_custom_module_source( @_ )
|
|
: $self->__update_custom_module_sources( @_ );
|
|
|
|
return $rv;
|
|
}
|
|
|
|
=head2 $file = $cb->write_custom_source_index( path => /path/to/package/root, [to => /path/to/index/file, verbose => BOOL] );
|
|
|
|
Writes the index for a custom repository root. Most users will not have to
|
|
worry about this, but administrators of a repository will need to make sure
|
|
their indexes are up to date.
|
|
|
|
The index will be written to a file called C<packages.txt> in your repository
|
|
root, which you can specify with the C<path> argument. You can override this
|
|
location by specifying the C<to> argument, but in normal operation, that should
|
|
not be required.
|
|
|
|
Once the index file is written, users can then add the C<URI> pointing to
|
|
the repository to their custom list of sources and start using it right away. See the C<< $cb->add_custom_source >> method for user details.
|
|
|
|
=cut
|
|
|
|
sub write_custom_source_index {
|
|
return shift->__write_custom_module_index( @_ );
|
|
}
|
|
|
|
1;
|
|
|
|
=pod
|
|
|
|
=head1 BUG REPORTS
|
|
|
|
Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
|
|
|
|
=head1 AUTHOR
|
|
|
|
This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
The CPAN++ interface (of which this module is a part of) is copyright (c)
|
|
2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
|
|
|
|
This library is free software; you may redistribute and/or modify it
|
|
under the same terms as Perl itself.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<CPANPLUS::Configure>, L<CPANPLUS::Module>, L<CPANPLUS::Module::Author>,
|
|
L<CPANPLUS::Selfupdate>
|
|
|
|
=cut
|
|
|
|
# Local variables:
|
|
# c-indentation-style: bsd
|
|
# c-basic-offset: 4
|
|
# indent-tabs-mode: nil
|
|
# End:
|
|
# vim: expandtab shiftwidth=4:
|
|
|
|
__END__
|
|
|
|
todo:
|
|
sub dist { # not sure about this one -- probably already done
|
|
enough in Module.pm
|
|
sub reports { # in Module.pm, wrapper here
|
|
|
|
|