1841 lines
54 KiB
Perl
1841 lines
54 KiB
Perl
package CPANPLUS::Module;
|
|
|
|
use strict;
|
|
use vars qw[@ISA $VERSION];
|
|
$VERSION = "0.9910";
|
|
|
|
use CPANPLUS::Dist;
|
|
use CPANPLUS::Error;
|
|
use CPANPLUS::Module::Signature;
|
|
use CPANPLUS::Module::Checksums;
|
|
use CPANPLUS::Internals::Constants;
|
|
|
|
use FileHandle;
|
|
|
|
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
|
use IPC::Cmd qw[can_run run];
|
|
use File::Find qw[find];
|
|
use Params::Check qw[check];
|
|
use File::Basename qw[dirname];
|
|
use Module::Load::Conditional qw[can_load check_install];
|
|
|
|
$Params::Check::VERBOSE = 1;
|
|
|
|
@ISA = qw[ CPANPLUS::Module::Signature CPANPLUS::Module::Checksums];
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
CPANPLUS::Module - CPAN module objects for CPANPLUS
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
### get a module object from the CPANPLUS::Backend object
|
|
my $mod = $cb->module_tree('Some::Module');
|
|
|
|
### accessors
|
|
$mod->version;
|
|
$mod->package;
|
|
|
|
### methods
|
|
$mod->fetch;
|
|
$mod->extract;
|
|
$mod->install;
|
|
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
C<CPANPLUS::Module> creates objects from the information in the
|
|
source files. These can then be used to query and perform actions
|
|
on, like fetching or installing.
|
|
|
|
These objects should only be created internally. For C<fake> objects,
|
|
there's the C<CPANPLUS::Module::Fake> class. To obtain a module object
|
|
consult the C<CPANPLUS::Backend> documentation.
|
|
|
|
=cut
|
|
|
|
my $tmpl = {
|
|
module => { default => '', required => 1 }, # full module name
|
|
version => { default => '0.0' }, # version number
|
|
path => { default => '', required => 1 }, # extended path on the
|
|
# cpan mirror, like
|
|
# /author/id/K/KA/KANE
|
|
comment => { default => ''}, # comment on module
|
|
package => { default => '', required => 1 }, # package name, like
|
|
# 'bar-baz-1.03.tgz'
|
|
description => { default => '' }, # description of the
|
|
# module
|
|
dslip => { default => EMPTY_DSLIP }, # dslip information
|
|
_id => { required => 1 }, # id of the Internals
|
|
# parent object
|
|
_status => { no_override => 1 }, # stores status object
|
|
author => { default => '', required => 1,
|
|
allow => IS_AUTHOBJ }, # module author
|
|
mtime => { default => '' },
|
|
};
|
|
|
|
### some of these will be resolved by wrapper functions that
|
|
### do Clever Things to find the actual value, so don't create
|
|
### an autogenerated sub for that just here, take an alternate
|
|
### name to allow for a wrapper
|
|
{ my %rename = (
|
|
dslip => '_dslip'
|
|
);
|
|
|
|
### autogenerate accessors ###
|
|
for my $key ( keys %$tmpl ) {
|
|
no strict 'refs';
|
|
|
|
my $sub = $rename{$key} || $key;
|
|
|
|
*{__PACKAGE__."::$sub"} = sub {
|
|
$_[0]->{$key} = $_[1] if @_ > 1;
|
|
return $_[0]->{$key};
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
=pod
|
|
|
|
=head1 CLASS METHODS
|
|
|
|
=head2 accessors ()
|
|
|
|
Returns a list of all accessor methods to the object
|
|
|
|
=cut
|
|
|
|
### *name is an alias, include it explicitly
|
|
sub accessors { return ('name', keys %$tmpl) };
|
|
|
|
=head1 ACCESSORS
|
|
|
|
An objects of this class has the following accessors:
|
|
|
|
=over 4
|
|
|
|
=item name
|
|
|
|
Name of the module.
|
|
|
|
=item module
|
|
|
|
Name of the module.
|
|
|
|
=item version
|
|
|
|
Version of the module. Defaults to '0.0' if none was provided.
|
|
|
|
=item path
|
|
|
|
Extended path on the mirror.
|
|
|
|
=item comment
|
|
|
|
Any comment about the module -- largely unused.
|
|
|
|
=item package
|
|
|
|
The name of the package.
|
|
|
|
=item description
|
|
|
|
Description of the module -- only registered modules have this.
|
|
|
|
=item dslip
|
|
|
|
The five character dslip string, that represents meta-data of the
|
|
module -- again, only registered modules have this.
|
|
|
|
=cut
|
|
|
|
sub dslip {
|
|
my $self = shift;
|
|
|
|
### if this module has relevant dslip info, return it
|
|
return $self->_dslip if $self->_dslip ne EMPTY_DSLIP;
|
|
|
|
### if not, look at other modules in the same package,
|
|
### see if *they* have any dslip info
|
|
for my $mod ( $self->contains ) {
|
|
return $mod->_dslip if $mod->_dslip ne EMPTY_DSLIP;
|
|
}
|
|
|
|
### ok, really no dslip info found, return the default
|
|
return EMPTY_DSLIP;
|
|
}
|
|
|
|
|
|
=pod
|
|
|
|
=item status
|
|
|
|
The C<CPANPLUS::Module::Status> object associated with this object.
|
|
(see below).
|
|
|
|
=item author
|
|
|
|
The C<CPANPLUS::Module::Author> object associated with this object.
|
|
|
|
=item parent
|
|
|
|
The C<CPANPLUS::Internals> object that spawned this module object.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
### Alias ->name to ->module, for human beings.
|
|
*name = *module;
|
|
|
|
sub parent {
|
|
my $self = shift;
|
|
my $obj = CPANPLUS::Internals->_retrieve_id( $self->_id );
|
|
|
|
return $obj;
|
|
}
|
|
|
|
=head1 STATUS ACCESSORS
|
|
|
|
C<CPANPLUS> caches a lot of results from method calls and saves data
|
|
it collected along the road for later reuse.
|
|
|
|
C<CPANPLUS> uses this internally, but it is also available for the end
|
|
user. You can get a status object by calling:
|
|
|
|
$modobj->status
|
|
|
|
You can then query the object as follows:
|
|
|
|
=over 4
|
|
|
|
=item installer_type
|
|
|
|
The installer type used for this distribution. Will be one of
|
|
'makemaker' or 'build'. This determines whether C<CPANPLUS::Dist::MM>
|
|
or C<CPANPLUS::Dist::Build> will be used to build this distribution.
|
|
|
|
=item dist_cpan
|
|
|
|
The dist object used to do the CPAN-side of the installation. Either
|
|
a C<CPANPLUS::Dist::MM> or C<CPANPLUS::Dist::Build> object.
|
|
|
|
=item dist
|
|
|
|
The custom dist object used to do the operating specific side of the
|
|
installation, if you've chosen to use this. For example, if you've
|
|
chosen to install using the C<ports> format, this may be a
|
|
C<CPANPLUS::Dist::Ports> object.
|
|
|
|
Undefined if you didn't specify a separate format to install through.
|
|
|
|
=item prereqs | requires
|
|
|
|
A hashref of prereqs this distribution was found to have. Will look
|
|
something like this:
|
|
|
|
{ Carp => 0.01, strict => 0 }
|
|
|
|
Might be undefined if the distribution didn't have any prerequisites.
|
|
|
|
=item configure_requires
|
|
|
|
Like prereqs, but these are necessary to be installed before the
|
|
build process can even begin.
|
|
|
|
=item signature
|
|
|
|
Flag indicating, if a signature check was done, whether it was OK or
|
|
not.
|
|
|
|
=item extract
|
|
|
|
The directory this distribution was extracted to.
|
|
|
|
=item fetch
|
|
|
|
The location this distribution was fetched to.
|
|
|
|
=item readme
|
|
|
|
The text of this distributions README file.
|
|
|
|
=item uninstall
|
|
|
|
Flag indicating if an uninstall call was done successfully.
|
|
|
|
=item created
|
|
|
|
Flag indicating if the C<create> call to your dist object was done
|
|
successfully.
|
|
|
|
=item installed
|
|
|
|
Flag indicating if the C<install> call to your dist object was done
|
|
successfully.
|
|
|
|
=item checksums
|
|
|
|
The location of this distributions CHECKSUMS file.
|
|
|
|
=item checksum_ok
|
|
|
|
Flag indicating if the checksums check was done successfully.
|
|
|
|
=item checksum_value
|
|
|
|
The checksum value this distribution is expected to have
|
|
|
|
=back
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 $self = CPANPLUS::Module->new( OPTIONS )
|
|
|
|
This method returns a C<CPANPLUS::Module> object. Normal users
|
|
should never call this method directly, but instead use the
|
|
C<CPANPLUS::Backend> to obtain module objects.
|
|
|
|
This example illustrates a C<new()> call with all required arguments:
|
|
|
|
CPANPLUS::Module->new(
|
|
module => 'Foo',
|
|
path => 'authors/id/A/AA/AAA',
|
|
package => 'Foo-1.0.tgz',
|
|
author => $author_object,
|
|
_id => INTERNALS_OBJECT_ID,
|
|
);
|
|
|
|
Every accessor is also a valid option to pass to C<new>.
|
|
|
|
Returns a module object on success and false on failure.
|
|
|
|
=cut
|
|
|
|
|
|
sub new {
|
|
my($class, %hash) = @_;
|
|
|
|
### 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;
|
|
|
|
my $object = check( $tmpl, \%hash ) or return;
|
|
|
|
bless $object, $class;
|
|
|
|
return $object;
|
|
}
|
|
|
|
### only create status objects when they're actually asked for
|
|
sub status {
|
|
my $self = shift;
|
|
return $self->_status if $self->_status;
|
|
|
|
my $acc = Object::Accessor->new;
|
|
$acc->mk_accessors( qw[ installer_type dist_cpan dist prereqs
|
|
signature extract fetch readme uninstall
|
|
created installed prepared checksums files
|
|
checksum_ok checksum_value _fetch_from
|
|
configure_requires
|
|
] );
|
|
|
|
### create an alias from 'requires' to 'prereqs', so it's more in
|
|
### line with 'configure_requires';
|
|
$acc->mk_aliases( requires => 'prereqs' );
|
|
|
|
$self->_status( $acc );
|
|
|
|
return $self->_status;
|
|
}
|
|
|
|
|
|
### flush the cache of this object ###
|
|
sub _flush {
|
|
my $self = shift;
|
|
$self->status->mk_flush;
|
|
return 1;
|
|
}
|
|
|
|
=head2 $mod->package_name( [$package_string] )
|
|
|
|
Returns the name of the package a module is in. For C<Acme::Bleach>
|
|
that might be C<Acme-Bleach>.
|
|
|
|
=head2 $mod->package_version( [$package_string] )
|
|
|
|
Returns the version of the package a module is in. For a module
|
|
in the package C<Acme-Bleach-1.1.tar.gz> this would be C<1.1>.
|
|
|
|
=head2 $mod->package_extension( [$package_string] )
|
|
|
|
Returns the suffix added by the compression method of a package a
|
|
certain module is in. For a module in C<Acme-Bleach-1.1.tar.gz>, this
|
|
would be C<tar.gz>.
|
|
|
|
=head2 $mod->package_is_perl_core
|
|
|
|
Returns a boolean indicating of the package a particular module is in,
|
|
is actually a core perl distribution.
|
|
|
|
=head2 $mod->module_is_supplied_with_perl_core( [version => $]] )
|
|
|
|
Returns a boolean indicating whether C<ANY VERSION> of this module
|
|
was supplied with the current running perl's core package.
|
|
|
|
=head2 $mod->is_bundle
|
|
|
|
Returns a boolean indicating if the module you are looking at, is
|
|
actually a bundle. Bundles are identified as modules whose name starts
|
|
with C<Bundle::>.
|
|
|
|
=head2 $mod->is_autobundle;
|
|
|
|
Returns a boolean indicating if the module you are looking at, is
|
|
actually an autobundle as generated by C<< $cb->autobundle >>.
|
|
|
|
=head2 $mod->is_third_party
|
|
|
|
Returns a boolean indicating whether the package is a known third-party
|
|
module (i.e. it's not provided by the standard Perl distribution and
|
|
is not available on the CPAN, but on a third party software provider).
|
|
See L<Module::ThirdParty> for more details.
|
|
|
|
=head2 $mod->third_party_information
|
|
|
|
Returns a reference to a hash with more information about a third-party
|
|
module. See the documentation about C<module_information()> in
|
|
L<Module::ThirdParty> for more details.
|
|
|
|
=cut
|
|
|
|
{ ### fetches the test reports for a certain module ###
|
|
my %map = (
|
|
name => 0,
|
|
version => 1,
|
|
extension => 2,
|
|
);
|
|
|
|
while ( my($type, $index) = each %map ) {
|
|
my $name = 'package_' . $type;
|
|
|
|
no strict 'refs';
|
|
*$name = sub {
|
|
my $self = shift;
|
|
my $val = shift || $self->package;
|
|
my @res = $self->parent->_split_package_string( package => $val );
|
|
|
|
### return the corresponding index from the result
|
|
return $res[$index] if @res;
|
|
return;
|
|
};
|
|
}
|
|
|
|
sub package_is_perl_core {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
|
|
### check if the package looks like a perl core package
|
|
return 1 if $self->package_name eq PERL_CORE;
|
|
|
|
### address #44562: ::Module->package_is_perl_code : problem comparing
|
|
### version strings -- use $cb->_vcmp to avoid warnings when version
|
|
### have _ in them
|
|
|
|
my $core = $self->module_is_supplied_with_perl_core;
|
|
### ok, so it's found in the core, BUT it could be dual-lifed
|
|
if (defined $core) {
|
|
### if the package is newer than installed, then it's dual-lifed
|
|
return if $cb->_vcmp($self->version, $self->installed_version) > 0;
|
|
|
|
### if the package is newer or equal to the corelist,
|
|
### then it's dual-lifed
|
|
return if $cb->_vcmp( $self->version, $core ) >= 0;
|
|
|
|
### otherwise, it's older than corelist, thus unsuitable.
|
|
return 1;
|
|
}
|
|
|
|
### not in corelist, not a perl core package.
|
|
return;
|
|
}
|
|
|
|
sub module_is_supplied_with_perl_core {
|
|
my $self = shift;
|
|
my $ver = shift || $];
|
|
|
|
### allow it to be called as a package function as well like:
|
|
### CPANPLUS::Module::module_is_supplied_with_perl_core('Config')
|
|
### so that we can check the status of modules that aren't released
|
|
### to CPAN, but are part of the core.
|
|
my $name = ref $self ? $self->module : $self;
|
|
|
|
### check Module::CoreList to see if it's a core package
|
|
require Module::CoreList;
|
|
|
|
### Address #41157: Module::module_is_supplied_with_perl_core()
|
|
### broken for perl 5.10: Module::CoreList's version key for the
|
|
### hash has a different number of trailing zero than $] aka
|
|
### $PERL_VERSION.
|
|
|
|
my $core;
|
|
|
|
if ( exists $Module::CoreList::version{ 0+$ver }->{ $name } ) {
|
|
$core = $Module::CoreList::version{ 0+$ver }->{ $name };
|
|
$core = 0 unless $core;
|
|
}
|
|
return $core;
|
|
}
|
|
|
|
### make sure Bundle-Foo also gets flagged as bundle
|
|
sub is_bundle {
|
|
my $self = shift;
|
|
|
|
### cpan'd bundle
|
|
return 1 if $self->module =~ /^bundle(?:-|::)/i;
|
|
|
|
### autobundle
|
|
return 1 if $self->is_autobundle;
|
|
|
|
### neither
|
|
return;
|
|
}
|
|
|
|
### full path to a generated autobundle
|
|
sub is_autobundle {
|
|
my $self = shift;
|
|
my $conf = $self->parent->configure_object;
|
|
my $prefix = $conf->_get_build('autobundle_prefix');
|
|
|
|
return 1 if $self->module eq $prefix;
|
|
return;
|
|
}
|
|
|
|
sub is_third_party {
|
|
my $self = shift;
|
|
|
|
return unless can_load( modules => { 'Module::ThirdParty' => 0 } );
|
|
|
|
return Module::ThirdParty::is_3rd_party( $self->name );
|
|
}
|
|
|
|
sub third_party_information {
|
|
my $self = shift;
|
|
|
|
return unless $self->is_third_party;
|
|
|
|
return Module::ThirdParty::module_information( $self->name );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $clone = $self->clone
|
|
|
|
Clones the current module object for tinkering with.
|
|
It will have a clean C<CPANPLUS::Module::Status> object, as well as
|
|
a fake C<CPANPLUS::Module::Author> object.
|
|
|
|
=cut
|
|
|
|
{ ### accessors don't change during run time, so only compute once
|
|
my @acc = grep !/status/, __PACKAGE__->accessors();
|
|
|
|
sub clone {
|
|
my $self = shift;
|
|
|
|
### clone the object ###
|
|
my %data = map { $_ => $self->$_ } @acc;
|
|
|
|
my $obj = CPANPLUS::Module::Fake->new( %data );
|
|
|
|
return $obj;
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $where = $self->fetch
|
|
|
|
Fetches the module from a CPAN mirror.
|
|
Look at L<CPANPLUS::Internals::Fetch::_fetch()> for details on the
|
|
options you can pass.
|
|
|
|
=cut
|
|
|
|
sub fetch {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
|
|
### custom args
|
|
my %args = ( module => $self );
|
|
|
|
### if a custom fetch location got specified before, add that here
|
|
$args{fetch_from} = $self->status->_fetch_from
|
|
if $self->status->_fetch_from;
|
|
|
|
my $where = $cb->_fetch( @_, %args ) or return;
|
|
|
|
### do an md5 check ###
|
|
if( !$self->status->_fetch_from and
|
|
$cb->configure_object->get_conf('md5') and
|
|
$self->package ne CHECKSUMS
|
|
) {
|
|
unless( $self->_validate_checksum ) {
|
|
error( loc( "Checksum error for '%1' -- will not trust package",
|
|
$self->package) );
|
|
return;
|
|
}
|
|
}
|
|
|
|
return $where;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $path = $self->extract
|
|
|
|
Extracts the fetched module.
|
|
Look at L<CPANPLUS::Internals::Extract::_extract()> for details on
|
|
the options you can pass.
|
|
|
|
=cut
|
|
|
|
sub extract {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
|
|
unless( $self->status->fetch ) {
|
|
error( loc( "You have not fetched '%1' yet -- cannot extract",
|
|
$self->module) );
|
|
return;
|
|
}
|
|
|
|
### can't extract these, so just use the basedir for the file
|
|
if( $self->is_autobundle ) {
|
|
|
|
### this is expected to be set after an extract call
|
|
$self->get_installer_type;
|
|
|
|
return $self->status->extract( dirname( $self->status->fetch ) );
|
|
}
|
|
|
|
return $cb->_extract( @_, module => $self );
|
|
}
|
|
|
|
=head2 $type = $self->get_installer_type([prefer_makefile => BOOL])
|
|
|
|
Gets the installer type for this module. This may either be C<build> or
|
|
C<makemaker>. If C<Module::Build> is unavailable or no installer type
|
|
is available, it will fall back to C<makemaker>. If both are available,
|
|
it will pick the one indicated by your config, or by the
|
|
C<prefer_makefile> option you can pass to this function.
|
|
|
|
Returns the installer type on success, and false on error.
|
|
|
|
=cut
|
|
|
|
sub get_installer_type {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
my $conf = $cb->configure_object;
|
|
my %hash = @_;
|
|
|
|
my ($prefer_makefile,$verbose);
|
|
my $tmpl = {
|
|
prefer_makefile => { default => $conf->get_conf('prefer_makefile'),
|
|
store => \$prefer_makefile, allow => BOOLEANS },
|
|
verbose => { default => $conf->get_conf('verbose'),
|
|
store => \$verbose },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
my $type;
|
|
|
|
### autobundles use their own installer, so return that
|
|
if( $self->is_autobundle ) {
|
|
$type = INSTALLER_AUTOBUNDLE;
|
|
|
|
} else {
|
|
my $extract = $self->status->extract();
|
|
unless( $extract ) {
|
|
error(loc(
|
|
"Cannot determine installer type of unextracted module '%1'",
|
|
$self->module
|
|
));
|
|
return;
|
|
}
|
|
|
|
### check if it's a makemaker or a module::build type dist ###
|
|
my $found_build = -e BUILD_PL->( $extract );
|
|
my $found_makefile = -e MAKEFILE_PL->( $extract );
|
|
|
|
$type = INSTALLER_BUILD if !$prefer_makefile && $found_build;
|
|
$type = INSTALLER_BUILD if $found_build && !$found_makefile;
|
|
$type = INSTALLER_MM if $prefer_makefile && $found_makefile;
|
|
$type = INSTALLER_MM if $found_makefile && !$found_build;
|
|
# Special case Module::Build to always use INSTALLER_MM
|
|
$type = INSTALLER_MM if $self->package =~ m{^Module-Build-\d};
|
|
|
|
}
|
|
|
|
### ok, so it's a 'build' installer, but you don't /have/ module build
|
|
### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
|
|
if( $type and $type eq INSTALLER_BUILD and (
|
|
not CPANPLUS::Dist->has_dist_type( INSTALLER_BUILD )
|
|
or not $cb->module_tree( INSTALLER_BUILD )
|
|
->is_uptodate( version => '0.60' )
|
|
) ) {
|
|
|
|
### XXX this is for recording purposes only. We *have* to install
|
|
### these before even creating a dist object, or we'll get an error
|
|
### saying 'no such dist type';
|
|
### XXX duplicated from CPANPLUS::Selfupdate. fix somehow?
|
|
my $href = $self->status->configure_requires || {};
|
|
my $deps = { INSTALLER_BUILD, '0.60', %$href };
|
|
|
|
$self->status->configure_requires( $deps );
|
|
|
|
msg(loc("This module requires '%1' and '%2' to be installed first. ".
|
|
"Adding these modules to your prerequisites list",
|
|
'Module::Build', INSTALLER_BUILD
|
|
), $verbose );
|
|
|
|
|
|
### ok, actually we found neither ###
|
|
} elsif ( !$type ) {
|
|
error( loc( "Unable to find '%1' or '%2' for '%3'; ".
|
|
"Will default to '%4' but might be unable ".
|
|
"to install!", BUILD_PL->(), MAKEFILE_PL->(),
|
|
$self->module, INSTALLER_MM ) );
|
|
$type = INSTALLER_MM;
|
|
}
|
|
|
|
return $self->status->installer_type( $type ) if $type;
|
|
return;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $dist = $self->dist([target => 'prepare|create', format => DISTRIBUTION_TYPE, args => {key => val}]);
|
|
|
|
Create a distribution object, ready to be installed.
|
|
Distribution type defaults to your config settings
|
|
|
|
The optional C<args> hashref is passed on to the specific distribution
|
|
types' C<create> method after being dereferenced.
|
|
|
|
Returns a distribution object on success, false on failure.
|
|
|
|
See C<CPANPLUS::Dist> for details.
|
|
|
|
=cut
|
|
|
|
sub dist {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
my $conf = $cb->configure_object;
|
|
my %hash = @_;
|
|
|
|
### have you determined your installer type yet? if not, do it here,
|
|
### we need the info
|
|
$self->get_installer_type unless $self->status->installer_type;
|
|
|
|
my($type,$args,$target);
|
|
my $tmpl = {
|
|
format => { default => $conf->get_conf('dist_type') ||
|
|
$self->status->installer_type,
|
|
store => \$type },
|
|
target => { default => TARGET_CREATE, store => \$target },
|
|
args => { default => {}, store => \$args },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
### ok, check for $type. Do we have it?
|
|
unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
|
|
|
|
### ok, we don't have it. Is it C::D::Build? if so we can install the
|
|
### whole thing now
|
|
### XXX we _could_ do this for any type we don't have actually...
|
|
if( $type eq INSTALLER_BUILD ) {
|
|
msg(loc("Bootstrapping installer '%1'", $type));
|
|
|
|
### don't propagate the format, it's the one we're trying to
|
|
### bootstrap, so it'll be an infinite loop if we do
|
|
|
|
$cb->module_tree( $type )->install( target => $target, %$args ) or
|
|
do {
|
|
error(loc("Could not bootstrap installer '%1' -- ".
|
|
"can not continue", $type));
|
|
return;
|
|
};
|
|
|
|
### re-scan for available modules now
|
|
CPANPLUS::Dist->rescan_dist_types;
|
|
|
|
unless( CPANPLUS::Dist->has_dist_type( $type ) ) {
|
|
error(loc("Newly installed installer type '%1' should be ".
|
|
"available, but is not! -- aborting", $type));
|
|
return;
|
|
} else {
|
|
msg(loc("Installer '%1' successfully bootstrapped", $type));
|
|
}
|
|
|
|
### some other plugin you don't have. Abort
|
|
} else {
|
|
error(loc("Installer type '%1' not found. Please verify your ".
|
|
"installation -- aborting", $type ));
|
|
return;
|
|
}
|
|
}
|
|
|
|
### make sure we don't overwrite it, just in case we came
|
|
### back from a ->save_state. This allows restoration to
|
|
### work correctly
|
|
my( $dist, $dist_cpan );
|
|
|
|
unless( $dist = $self->status->dist ) {
|
|
$dist = $type->new( module => $self ) or return;
|
|
$self->status->dist( $dist );
|
|
}
|
|
|
|
unless( $dist_cpan = $self->status->dist_cpan ) {
|
|
|
|
$dist_cpan = $type eq $self->status->installer_type
|
|
? $self->status->dist
|
|
: $self->status->installer_type->new( module => $self );
|
|
|
|
|
|
$self->status->dist_cpan( $dist_cpan );
|
|
}
|
|
|
|
|
|
DIST: {
|
|
### just wanted the $dist object?
|
|
last DIST if $target eq TARGET_INIT;
|
|
|
|
### first prepare the dist
|
|
$dist->prepare( %$args ) or return;
|
|
$self->status->prepared(1);
|
|
|
|
### you just wanted us to prepare?
|
|
last DIST if $target eq TARGET_PREPARE;
|
|
|
|
$dist->create( %$args ) or return;
|
|
$self->status->created(1);
|
|
}
|
|
|
|
return $dist;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $mod->prepare( )
|
|
|
|
Convenience method around C<install()> that prepares a module
|
|
without actually building it. This is equivalent to invoking C<install>
|
|
with C<target> set to C<prepare>
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub prepare {
|
|
my $self = shift;
|
|
return $self->install( @_, target => TARGET_PREPARE );
|
|
}
|
|
|
|
=head2 $bool = $mod->create( )
|
|
|
|
Convenience method around C<install()> that creates a module.
|
|
This is equivalent to invoking C<install> with C<target> set to
|
|
C<create>
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub create {
|
|
my $self = shift;
|
|
return $self->install( @_, target => TARGET_CREATE );
|
|
}
|
|
|
|
=head2 $bool = $mod->test( )
|
|
|
|
Convenience wrapper around C<install()> that tests a module, without
|
|
installing it.
|
|
It's the equivalent to invoking C<install()> with C<target> set to
|
|
C<create> and C<skiptest> set to C<0>.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub test {
|
|
my $self = shift;
|
|
return $self->install( @_, target => TARGET_CREATE, skiptest => 0 );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $self->install([ target => 'init|prepare|create|install', format => FORMAT_TYPE, extractdir => DIRECTORY, fetchdir => DIRECTORY, prefer_bin => BOOL, force => BOOL, verbose => BOOL, ..... ]);
|
|
|
|
Installs the current module. This includes fetching it and extracting
|
|
it, if this hasn't been done yet, as well as creating a distribution
|
|
object for it.
|
|
|
|
This means you can pass it more arguments than described above, which
|
|
will be passed on to the relevant methods as they are called.
|
|
|
|
See C<CPANPLUS::Internals::Fetch>, C<CPANPLUS::Internals::Extract> and
|
|
C<CPANPLUS::Dist> for details.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub install {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
my $conf = $cb->configure_object;
|
|
my %hash = @_;
|
|
|
|
my $args; my $target; my $format;
|
|
{ ### so we can use the rest of the args to the create calls etc ###
|
|
local $Params::Check::NO_DUPLICATES = 1;
|
|
local $Params::Check::ALLOW_UNKNOWN = 1;
|
|
|
|
### targets 'dist' and 'test' are now completely ignored ###
|
|
my $tmpl = {
|
|
### match this allow list with Dist->_resolve_prereqs
|
|
target => { default => TARGET_INSTALL, store => \$target,
|
|
allow => [TARGET_PREPARE, TARGET_CREATE,
|
|
TARGET_INSTALL, TARGET_INIT ] },
|
|
force => { default => $conf->get_conf('force'), },
|
|
verbose => { default => $conf->get_conf('verbose'), },
|
|
format => { default => $conf->get_conf('dist_type'),
|
|
store => \$format },
|
|
};
|
|
|
|
$args = check( $tmpl, \%hash ) or return;
|
|
}
|
|
|
|
|
|
### if this target isn't 'install', we will need to at least 'create'
|
|
### every prereq, so it can build
|
|
### XXX prereq_target of 'prepare' will do weird things here, and is
|
|
### not supported.
|
|
$args->{'prereq_target'} ||= TARGET_CREATE if $target ne TARGET_INSTALL;
|
|
|
|
### check if it's already uptodate ###
|
|
if( $target eq TARGET_INSTALL and !$args->{'force'} and
|
|
!$self->package_is_perl_core() and # separate rules apply
|
|
( $self->status->installed() or $self->is_uptodate ) and
|
|
!INSTALL_VIA_PACKAGE_MANAGER->($format)
|
|
) {
|
|
msg(loc("Module '%1' already up to date, won't install without force",
|
|
$self->module), $args->{'verbose'} );
|
|
return $self->status->installed(1);
|
|
}
|
|
|
|
# if it's a non-installable core package, abort the install.
|
|
if( $self->package_is_perl_core() ) {
|
|
# if the installed is newer, say so.
|
|
if( $self->installed_version > $self->version ) {
|
|
error(loc("The core Perl %1 module '%2' (%3) is more ".
|
|
"recent than the latest release on CPAN (%4). ".
|
|
"Aborting install.",
|
|
$], $self->module, $self->installed_version,
|
|
$self->version ) );
|
|
# if the installed matches, say so.
|
|
} elsif( $self->installed_version == $self->version ) {
|
|
error(loc("The core Perl %1 module '%2' (%3) can only ".
|
|
"be installed by Perl itself. ".
|
|
"Aborting install.",
|
|
$], $self->module, $self->installed_version ) );
|
|
# otherwise, the installed is older; say so.
|
|
} else {
|
|
error(loc("The core Perl %1 module '%2' can only be ".
|
|
"upgraded from %3 to %4 by Perl itself (%5). ".
|
|
"Aborting install.",
|
|
$], $self->module, $self->installed_version,
|
|
$self->version, $self->package ) );
|
|
}
|
|
return;
|
|
|
|
### it might be a known 3rd party module
|
|
} elsif ( $self->is_third_party ) {
|
|
my $info = $self->third_party_information;
|
|
error(loc(
|
|
"%1 is a known third-party module.\n\n".
|
|
"As it isn't available on the CPAN, CPANPLUS can't install " .
|
|
"it automatically. Therefore you need to install it manually " .
|
|
"before proceeding.\n\n".
|
|
"%2 is part of %3, published by %4, and should be available ".
|
|
"for download at the following address:\n\t%5",
|
|
$self->name, $self->name, $info->{name}, $info->{author},
|
|
$info->{url}
|
|
));
|
|
|
|
return;
|
|
}
|
|
|
|
### fetch it if need be ###
|
|
unless( $self->status->fetch ) {
|
|
my $params;
|
|
for (qw[prefer_bin fetchdir]) {
|
|
$params->{$_} = $args->{$_} if exists $args->{$_};
|
|
}
|
|
for (qw[force verbose]) {
|
|
$params->{$_} = $args->{$_} if defined $args->{$_};
|
|
}
|
|
$self->fetch( %$params ) or return;
|
|
}
|
|
|
|
### extract it if need be ###
|
|
unless( $self->status->extract ) {
|
|
my $params;
|
|
for (qw[prefer_bin extractdir]) {
|
|
$params->{$_} = $args->{$_} if exists $args->{$_};
|
|
}
|
|
for (qw[force verbose]) {
|
|
$params->{$_} = $args->{$_} if defined $args->{$_};
|
|
}
|
|
$self->extract( %$params ) or return;
|
|
}
|
|
|
|
$args->{'prereq_format'} = $format if $format;
|
|
$format ||= $self->status->installer_type;
|
|
|
|
unless( $format ) {
|
|
error( loc( "Don't know what installer to use; " .
|
|
"Couldn't find either '%1' or '%2' in the extraction " .
|
|
"directory '%3' -- will be unable to install",
|
|
BUILD_PL->(), MAKEFILE_PL->(), $self->status->extract ) );
|
|
|
|
$self->status->installed(0);
|
|
return;
|
|
}
|
|
|
|
|
|
### do SIGNATURE checks? ###
|
|
### XXX check status and not recheck EVERY time?
|
|
if( $conf->get_conf('signature') ) {
|
|
unless( $self->check_signature( verbose => $args->{verbose} ) ) {
|
|
error( loc( "Signature check failed for module '%1' ".
|
|
"-- Not trusting this module, aborting install",
|
|
$self->module ) );
|
|
$self->status->signature(0);
|
|
|
|
### send out test report on broken sig
|
|
if( $conf->get_conf('cpantest') ) {
|
|
$cb->_send_report(
|
|
module => $self,
|
|
failed => 1,
|
|
buffer => CPANPLUS::Error->stack_as_string,
|
|
verbose => $args->{verbose},
|
|
force => $args->{force},
|
|
) or error(loc("Failed to send test report for '%1'",
|
|
$self->module ) );
|
|
}
|
|
|
|
return;
|
|
|
|
} else {
|
|
### signature OK ###
|
|
$self->status->signature(1);
|
|
}
|
|
}
|
|
|
|
### a target of 'create' basically means not to run make test ###
|
|
### eh, no it /doesn't/.. skiptest => 1 means skiptest => 1.
|
|
#$args->{'skiptest'} = 1 if $target eq 'create';
|
|
|
|
### bundle rules apply ###
|
|
if( $self->is_bundle ) {
|
|
### check what we need to install ###
|
|
my @prereqs = $self->bundle_modules();
|
|
unless( @prereqs ) {
|
|
error( loc( "Bundle '%1' does not specify any modules to install",
|
|
$self->module ) );
|
|
|
|
### XXX mark an error here? ###
|
|
}
|
|
}
|
|
|
|
my $dist = $self->dist( format => $format,
|
|
target => $target,
|
|
args => $args );
|
|
unless( $dist ) {
|
|
error( loc( "Unable to create a new distribution object for '%1' " .
|
|
"-- cannot continue", $self->module ) );
|
|
return;
|
|
}
|
|
|
|
return 1 if $target ne TARGET_INSTALL;
|
|
|
|
my $ok = $dist->install( %$args ) ? 1 : 0;
|
|
|
|
$self->status->installed($ok);
|
|
|
|
return 1 if $ok;
|
|
return;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 @list = $self->bundle_modules()
|
|
|
|
Returns a list of module objects the Bundle specifies.
|
|
|
|
This requires you to have extracted the bundle already, using the
|
|
C<extract()> method.
|
|
|
|
Returns false on error.
|
|
|
|
=cut
|
|
|
|
sub bundle_modules {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
|
|
unless( $self->is_bundle ) {
|
|
error( loc("'%1' is not a bundle", $self->module ) );
|
|
return;
|
|
}
|
|
|
|
my @files;
|
|
|
|
### autobundles are special files generated by CPANPLUS. If we can
|
|
### read the file, we can determine the prereqs
|
|
if( $self->is_autobundle ) {
|
|
my $where;
|
|
unless( $where = $self->status->fetch ) {
|
|
error(loc("Don't know where '%1' was fetched to", $self->package));
|
|
return;
|
|
}
|
|
|
|
push @files, $where
|
|
|
|
### regular bundle::* upload
|
|
} else {
|
|
my $dir;
|
|
unless( $dir = $self->status->extract ) {
|
|
error(loc("Don't know where '%1' was extracted to", $self->module));
|
|
return;
|
|
}
|
|
|
|
find( {
|
|
wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
|
|
no_chdir => 1,
|
|
}, $dir );
|
|
}
|
|
|
|
my $prereqs = {}; my @list; my $seen = {};
|
|
for my $file ( @files ) {
|
|
my $fh = FileHandle->new($file)
|
|
or( error(loc("Could not open '%1' for reading: %2",
|
|
$file,$!)), next );
|
|
|
|
my $flag;
|
|
while( local $_ = <$fh> ) {
|
|
### quick hack to read past the header of the file ###
|
|
last if $flag && m|^=head|i;
|
|
|
|
### from perldoc cpan:
|
|
### =head1 CONTENTS
|
|
### In this pod section each line obeys the format
|
|
### Module_Name [Version_String] [- optional text]
|
|
$flag = 1 if m|^=head1 CONTENTS|i;
|
|
|
|
if ($flag && /^(?!=)(\S+)\s*(\S+)?/) {
|
|
my $module = $1;
|
|
my $version = $cb->_version_to_number( version => $2 );
|
|
|
|
my $obj = $cb->module_tree($module);
|
|
|
|
unless( $obj ) {
|
|
error(loc("Cannot find bundled module '%1'", $module),
|
|
loc("-- it does not seem to exist") );
|
|
next;
|
|
}
|
|
|
|
### make sure we list no duplicates ###
|
|
unless( $seen->{ $obj->module }++ ) {
|
|
push @list, $obj;
|
|
$prereqs->{ $module } =
|
|
$cb->_version_to_number( version => $version );
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
### store the prereqs we just found ###
|
|
$self->status->prereqs( $prereqs );
|
|
|
|
return @list;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $text = $self->readme
|
|
|
|
Fetches the readme belonging to this module and stores it under
|
|
C<< $obj->status->readme >>. Returns the readme as a string on
|
|
success and returns false on failure.
|
|
|
|
=cut
|
|
|
|
sub readme {
|
|
my $self = shift;
|
|
my $conf = $self->parent->configure_object;
|
|
|
|
### did we already dl the readme once? ###
|
|
return $self->status->readme() if $self->status->readme();
|
|
|
|
### this should be core ###
|
|
return unless can_load( modules => { FileHandle => '0.0' },
|
|
verbose => 1,
|
|
);
|
|
|
|
### get a clone of the current object, with a fresh status ###
|
|
my $obj = $self->clone or return;
|
|
|
|
### munge the package name
|
|
my $pkg = README->( $obj );
|
|
$obj->package($pkg);
|
|
|
|
my $file;
|
|
{ ### disable checksum fetches on readme downloads
|
|
|
|
my $tmp = $conf->get_conf( 'md5' );
|
|
$conf->set_conf( md5 => 0 );
|
|
|
|
$file = $obj->fetch;
|
|
|
|
$conf->set_conf( md5 => $tmp );
|
|
|
|
return unless $file;
|
|
}
|
|
|
|
### read the file into a scalar, to store in the original object ###
|
|
my $fh = new FileHandle;
|
|
unless( $fh->open($file) ) {
|
|
error( loc( "Could not open file '%1': %2", $file, $! ) );
|
|
return;
|
|
}
|
|
|
|
my $in = do{ local $/; <$fh> };
|
|
$fh->close;
|
|
|
|
return $self->status->readme( $in );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $version = $self->installed_version()
|
|
|
|
Returns the currently installed version of this module, if any.
|
|
|
|
=head2 $where = $self->installed_file()
|
|
|
|
Returns the location of the currently installed file of this module,
|
|
if any.
|
|
|
|
=head2 $dir = $self->installed_dir()
|
|
|
|
Returns the directory (or more accurately, the C<@INC> handle) from
|
|
which this module was loaded, if any.
|
|
|
|
=head2 $bool = $self->is_uptodate([version => VERSION_NUMBER])
|
|
|
|
Returns a boolean indicating if this module is uptodate or not.
|
|
|
|
=cut
|
|
|
|
### uptodate/installed functions
|
|
{ my $map = { # hashkey, alternate rv
|
|
installed_version => ['version', 0 ],
|
|
installed_file => ['file', ''],
|
|
installed_dir => ['dir', ''],
|
|
is_uptodate => ['uptodate', 0 ],
|
|
};
|
|
|
|
while( my($method, $aref) = each %$map ) {
|
|
my($key,$alt_rv) = @$aref;
|
|
|
|
no strict 'refs';
|
|
*$method = sub {
|
|
### 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, so this should not
|
|
### be needed anymore
|
|
#local @INC = CPANPLUS::inc->original_inc;
|
|
|
|
my $self = shift;
|
|
|
|
### make sure check_install is not looking in %INC, as
|
|
### that may contain some of our sneakily loaded modules
|
|
### that aren't installed as such. -- kane
|
|
local $Module::Load::Conditional::CHECK_INC_HASH = 0;
|
|
### this should all that is required for deprecated core modules
|
|
local $Module::Load::Conditional::DEPRECATED = 1;
|
|
my $href = check_install(
|
|
module => $self->module,
|
|
version => $self->version,
|
|
@_,
|
|
);
|
|
|
|
### Don't trust modules which are the result of @INC hooks
|
|
### FatPacker uses this trickery and it causes WTF moments
|
|
return $alt_rv if defined $href->{dir} && ref $href->{dir};
|
|
|
|
return $href->{$key} || $alt_rv;
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
|
|
=pod
|
|
|
|
=head2 $href = $self->details()
|
|
|
|
Returns a hashref with key/value pairs offering more information about
|
|
a particular module. For example, for C<Time::HiRes> it might look like
|
|
this:
|
|
|
|
Author Jarkko Hietaniemi (jhi@iki.fi)
|
|
Description High resolution time, sleep, and alarm
|
|
Development Stage Released
|
|
Installed File /usr/local/perl/lib/Time/Hires.pm
|
|
Interface Style plain Functions, no references used
|
|
Language Used C and perl, a C compiler will be needed
|
|
Package Time-HiRes-1.65.tar.gz
|
|
Public License Unknown
|
|
Support Level Developer
|
|
Version Installed 1.52
|
|
Version on CPAN 1.65
|
|
|
|
=cut
|
|
|
|
sub details {
|
|
my $self = shift;
|
|
my $conf = $self->parent->configure_object();
|
|
my $cb = $self->parent;
|
|
my %hash = @_;
|
|
|
|
my $res = {
|
|
Author => loc("%1 (%2)", $self->author->author(),
|
|
$self->author->email() ),
|
|
Package => $self->package,
|
|
Description => $self->description || loc('None given'),
|
|
'Version on CPAN' => $self->version,
|
|
};
|
|
|
|
### check if we have the module installed
|
|
### if so, add version have and version on cpan
|
|
$res->{'Version Installed'} = $self->installed_version
|
|
if $self->installed_version;
|
|
$res->{'Installed File'} = $self->installed_file if $self->installed_file;
|
|
|
|
my $i = 0;
|
|
for my $item( split '', $self->dslip ) {
|
|
$res->{ $cb->_dslip_defs->[$i]->[0] } =
|
|
$cb->_dslip_defs->[$i]->[1]->{$item} || loc('Unknown');
|
|
$i++;
|
|
}
|
|
|
|
return $res;
|
|
}
|
|
|
|
=head2 @list = $self->contains()
|
|
|
|
Returns a list of module objects that represent the modules also
|
|
present in the package of this module.
|
|
|
|
For example, for C<Archive::Tar> this might return:
|
|
|
|
Archive::Tar
|
|
Archive::Tar::Constant
|
|
Archive::Tar::File
|
|
|
|
=cut
|
|
|
|
sub contains {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
my $pkg = $self->package;
|
|
|
|
my @mods = $cb->search( type => 'package', allow => [qr/^$pkg$/] );
|
|
|
|
return @mods;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 @list_of_hrefs = $self->fetch_report()
|
|
|
|
This function queries the CPAN testers database at
|
|
I<http://testers.cpan.org/> for test results of specified module
|
|
objects, module names or distributions.
|
|
|
|
Look at L<CPANPLUS::Internals::Report::_query_report()> for details on
|
|
the options you can pass and the return value to expect.
|
|
|
|
=cut
|
|
|
|
sub fetch_report {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
|
|
return $cb->_query_report( @_, module => $self );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $self->uninstall([type => [all|man|prog])
|
|
|
|
This function uninstalls the specified module object.
|
|
|
|
You can install 2 types of files, either C<man> pages or C<prog>ram
|
|
files. Alternately you can specify C<all> to uninstall both (which
|
|
is the default).
|
|
|
|
Returns true on success and false on failure.
|
|
|
|
Do note that this does an uninstall via the so-called C<.packlist>,
|
|
so if you used a module installer like say, C<ports> or C<apt>, you
|
|
should not use this, but use your package manager instead.
|
|
|
|
=cut
|
|
|
|
sub uninstall {
|
|
my $self = shift;
|
|
my $conf = $self->parent->configure_object();
|
|
my %hash = @_;
|
|
|
|
my ($type,$verbose);
|
|
my $tmpl = {
|
|
type => { default => 'all', allow => [qw|man prog all|],
|
|
store => \$type },
|
|
verbose => { default => $conf->get_conf('verbose'),
|
|
store => \$verbose },
|
|
force => { default => $conf->get_conf('force') },
|
|
};
|
|
|
|
### XXX add a warning here if your default install dist isn't
|
|
### makefile or build -- that means you are using a package manager
|
|
### and this will not do what you think!
|
|
|
|
my $args = check( $tmpl, \%hash ) or return;
|
|
|
|
if( $conf->get_conf('dist_type') and (
|
|
($conf->get_conf('dist_type') ne INSTALLER_BUILD) or
|
|
($conf->get_conf('dist_type') ne INSTALLER_MM))
|
|
) {
|
|
msg(loc("You have a default installer type set (%1) ".
|
|
"-- you should probably use that package manager to " .
|
|
"uninstall modules", $conf->get_conf('dist_type')), $verbose);
|
|
}
|
|
|
|
### check if we even have the module installed -- no point in continuing
|
|
### otherwise
|
|
unless( $self->installed_version ) {
|
|
error( loc( "Module '%1' is not installed, so cannot uninstall",
|
|
$self->module ) );
|
|
return;
|
|
}
|
|
|
|
### nothing to uninstall ###
|
|
my $files = $self->files( type => $type ) or return;
|
|
my $dirs = $self->directory_tree( type => $type ) or return;
|
|
my $sudo = $conf->get_program('sudo');
|
|
|
|
### just in case there's no file; M::B doesn't provide .packlists yet ###
|
|
my $pack = $self->packlist;
|
|
$pack = $pack->[0]->packlist_file() if $pack;
|
|
|
|
### first remove the files, then the dirs if they are empty ###
|
|
my $flag = 0;
|
|
for my $file( @$files, $pack ) {
|
|
next unless defined $file && -f $file;
|
|
|
|
msg(loc("Unlinking '%1'", $file), $verbose);
|
|
|
|
my @cmd = ($^X, "-eunlink+q[$file]");
|
|
unshift @cmd, $sudo if $sudo;
|
|
|
|
my $buffer;
|
|
unless ( run( command => \@cmd,
|
|
verbose => $verbose,
|
|
buffer => \$buffer )
|
|
) {
|
|
error(loc("Failed to unlink '%1': '%2'",$file, $buffer));
|
|
$flag++;
|
|
}
|
|
}
|
|
|
|
for my $dir ( sort @$dirs ) {
|
|
local *DIR;
|
|
opendir DIR, $dir or next;
|
|
my @count = readdir(DIR);
|
|
close DIR;
|
|
|
|
next unless @count == 2; # . and ..
|
|
|
|
msg(loc("Removing '%1'", $dir), $verbose);
|
|
|
|
### this fails on my win2k machines.. it indeed leaves the
|
|
### dir, but it's not a critical error, since the files have
|
|
### been removed. --kane
|
|
#unless( rmdir $dir ) {
|
|
# error( loc( "Could not remove '%1': %2", $dir, $! ) )
|
|
# unless $^O eq 'MSWin32';
|
|
#}
|
|
|
|
my @cmd = ($^X, "-e", "rmdir q[$dir]");
|
|
unshift @cmd, $sudo if $sudo;
|
|
|
|
my $buffer;
|
|
unless ( run( command => \@cmd,
|
|
verbose => $verbose,
|
|
buffer => \$buffer )
|
|
) {
|
|
error(loc("Failed to rmdir '%1': %2",$dir,$buffer));
|
|
$flag++;
|
|
}
|
|
}
|
|
|
|
$self->status->uninstall(!$flag);
|
|
$self->status->installed( $flag ? 1 : undef);
|
|
|
|
return !$flag;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 @modobj = $self->distributions()
|
|
|
|
Returns a list of module objects representing all releases for this
|
|
module on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub distributions {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my @list = $self->author->distributions( %hash, module => $self ) or return;
|
|
|
|
### it's another release then by the same author ###
|
|
return grep { $_->package_name eq $self->package_name } @list;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 @list = $self->files ()
|
|
|
|
Returns a list of files used by this module, if it is installed.
|
|
|
|
=head2 @list = $self->directory_tree ()
|
|
|
|
Returns a list of directories used by this module.
|
|
|
|
=head2 @list = $self->packlist ()
|
|
|
|
Returns the C<ExtUtils::Packlist> object for this module.
|
|
|
|
=head2 @list = $self->validate ()
|
|
|
|
Returns a list of files that are missing for this modules, but
|
|
are present in the .packlist file.
|
|
|
|
=cut
|
|
|
|
for my $sub (qw[files directory_tree packlist validate]) {
|
|
no strict 'refs';
|
|
*$sub = sub {
|
|
return shift->_extutils_installed( @_, method => $sub );
|
|
}
|
|
}
|
|
|
|
### generic method to call an ExtUtils::Installed method ###
|
|
sub _extutils_installed {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
my $conf = $cb->configure_object;
|
|
my $home = $cb->_home_dir; # may be needed to fix up prefixes
|
|
my %hash = @_;
|
|
|
|
my ($verbose,$type,$method);
|
|
my $tmpl = {
|
|
verbose => { default => $conf->get_conf('verbose'),
|
|
store => \$verbose, },
|
|
type => { default => 'all',
|
|
allow => [qw|prog man all|],
|
|
store => \$type, },
|
|
method => { required => 1,
|
|
store => \$method,
|
|
allow => [qw|files directory_tree packlist
|
|
validate|],
|
|
},
|
|
};
|
|
|
|
my $args = check( $tmpl, \%hash ) or return;
|
|
|
|
### old versions of cygwin + perl < 5.8 are buggy here. bail out if we
|
|
### find we're being used by them
|
|
{ my $err = ON_OLD_CYGWIN;
|
|
if($err) { error($err); return };
|
|
}
|
|
|
|
return unless can_load(
|
|
modules => { 'ExtUtils::Installed' => '0.0' },
|
|
verbose => $verbose,
|
|
);
|
|
|
|
my @config_names = (
|
|
### lib
|
|
{ lib => 'privlib', # perl-only
|
|
arch => 'archlib', # compiled code
|
|
prefix => 'prefix', # prefix to both
|
|
},
|
|
### site
|
|
{ lib => 'sitelib',
|
|
arch => 'sitearch',
|
|
prefix => 'siteprefix',
|
|
},
|
|
### vendor
|
|
{ lib => 'vendorlib',
|
|
arch => 'vendorarch',
|
|
prefix => 'vendorprefix',
|
|
},
|
|
);
|
|
|
|
### search in your regular @INC, and anything you added to your config.
|
|
### this lets EU::Installed find .packlists that are *not* in the standard
|
|
### compiled in @INC path. Requires EU::I 1.42 or up. this addresses #33438
|
|
### make sure the archname path is also added, as that's where the .packlist
|
|
### files are written
|
|
my @libs;
|
|
for my $lib ( @{ $conf->get_conf('lib') } ) {
|
|
require Config;
|
|
|
|
### and just the standard dir
|
|
push @libs, $lib;
|
|
|
|
### figure out what an MM prefix expands to. Basically, it's the
|
|
### site install target from %Config, ie: /opt/lib/perl5/site_perl/5.8.8
|
|
### minus the site wide prefix, ie: /opt
|
|
### this lets users add the dir they have set as their EU::MM PREFIX
|
|
### to our 'lib' config and it Just Works
|
|
### the arch specific dir, ie:
|
|
### /opt/lib/perl5/site_perl/5.8.8/darwin-2level
|
|
### XXX is this the right thing to do?
|
|
|
|
### we add all 6 dir combos for prefixes:
|
|
### /foo/lib
|
|
### /foo/lib/arch
|
|
### /foo/site/lib
|
|
### /foo/site/lib/arch
|
|
### /foo/vendor/lib
|
|
### /foo/vendor/lib/arch
|
|
for my $href ( @config_names ) {
|
|
for my $key ( qw[lib arch] ) {
|
|
|
|
### look up the config value -- use EXP for the EXPANDED
|
|
### version, so no ~ etc are found in there
|
|
my $dir = $Config::Config{ $href->{ $key } .'exp' } or next;
|
|
my $prefix = $Config::Config{ $href->{prefix} };
|
|
|
|
### prefix may be relative to home, and contain a ~
|
|
### if so, fix it up.
|
|
$prefix =~ s/^~/$home/;
|
|
|
|
### remove the prefix from it, so we can append to our $lib
|
|
$dir =~ s/^\Q$prefix\E//;
|
|
|
|
### do the appending
|
|
push @libs, File::Spec->catdir( $lib, $dir );
|
|
|
|
}
|
|
}
|
|
}
|
|
|
|
my $inst;
|
|
unless( $inst = ExtUtils::Installed->new( extra_libs => \@libs ) ) {
|
|
error( loc("Could not create an '%1' object", 'ExtUtils::Installed' ) );
|
|
|
|
### in case it's being used directly... ###
|
|
return;
|
|
}
|
|
|
|
|
|
{ ### EU::Installed can die =/
|
|
my @files;
|
|
eval { @files = $inst->$method( $self->module, $type ) };
|
|
|
|
if( $@ ) {
|
|
chomp $@;
|
|
error( loc("Could not get '%1' for '%2': %3",
|
|
$method, $self->module, $@ ) );
|
|
return;
|
|
}
|
|
|
|
return wantarray ? @files : \@files;
|
|
}
|
|
}
|
|
|
|
=head2 $bool = $self->add_to_includepath;
|
|
|
|
Adds the current modules path to C<@INC> and C<$PERL5LIB>. This allows
|
|
you to add the module from its build dir to your path.
|
|
|
|
It also adds the current modules C<bin> and/or C<script> paths to
|
|
the PATH.
|
|
|
|
You can reset C<$PATH>, C<@INC> and C<$PERL5LIB> to their original state when you
|
|
started the program, by calling:
|
|
|
|
$self->parent->flush('lib');
|
|
|
|
=cut
|
|
|
|
sub add_to_includepath {
|
|
my $self = shift;
|
|
my $cb = $self->parent;
|
|
|
|
if( my $dir = $self->status->extract ) {
|
|
|
|
$cb->_add_to_includepath(
|
|
directories => [
|
|
File::Spec->catdir(BLIB->($dir), LIB),
|
|
File::Spec->catdir(BLIB->($dir), ARCH),
|
|
BLIB->($dir),
|
|
]
|
|
) or return;
|
|
|
|
$cb->_add_to_path(
|
|
directories => [
|
|
File::Spec->catdir(BLIB->($dir), SCRIPT),
|
|
File::Spec->catdir(BLIB->($dir), BIN),
|
|
]
|
|
) or return;
|
|
|
|
} else {
|
|
error(loc( "No extract dir registered for '%1' -- can not add ".
|
|
"add builddir to search path!", $self->module ));
|
|
return;
|
|
}
|
|
|
|
return 1;
|
|
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $path = $self->best_path_to_module_build();
|
|
|
|
B<OBSOLETE>
|
|
|
|
If a newer version of Module::Build is found in your path, it will
|
|
return this C<special> path. If the newest version of C<Module::Build>
|
|
is found in your regular C<@INC>, the method will return false. This
|
|
indicates you do not need to add a special directory to your C<@INC>.
|
|
|
|
Note that this is only relevant if you're building your own
|
|
C<CPANPLUS::Dist::*> plugin -- the built-in dist types already have
|
|
this taken care of.
|
|
|
|
=cut
|
|
|
|
### make sure we're always running 'perl Build.PL' and friends
|
|
### against the highest version of module::build available
|
|
sub best_path_to_module_build {
|
|
my $self = shift;
|
|
|
|
### Since M::B will actually shell out and run the Build.PL, we must
|
|
### make sure it refinds the proper version of M::B in the path.
|
|
### that may be either in our cp::inc or in site_perl, or even a
|
|
### new M::B being installed.
|
|
### don't add anything else here, as that might screw up prereq checks
|
|
|
|
### XXX this might be needed for Dist::MM too, if a makefile.pl is
|
|
### masquerading as a Build.PL
|
|
|
|
### did we find the most recent module::build in our installer path?
|
|
|
|
### XXX can't do changes to @INC, they're being ignored by
|
|
### new_from_context when writing a Build script. see ticket:
|
|
### #8826 Module::Build ignores changes to @INC when writing Build
|
|
### from new_from_context
|
|
### XXX applied schwern's patches (as seen on CPANPLUS::Devel 10/12/04)
|
|
### and upped the version to 0.26061 of the bundled version, and things
|
|
### work again
|
|
|
|
### this functionality is now obsolete -- prereqs should be installed
|
|
### and we no longer use the CPANPLUS::inc magic.. so comment this out.
|
|
# require Module::Build;
|
|
# if( CPANPLUS::inc->path_to('Module::Build') and (
|
|
# CPANPLUS::inc->path_to('Module::Build') eq
|
|
# CPANPLUS::inc->installer_path )
|
|
# ) {
|
|
#
|
|
# ### if the module being installed is *not* Module::Build
|
|
# ### itself -- as that would undoubtedly be newer -- add
|
|
# ### the path to the installers to @INC
|
|
# ### if it IS module::build itself, add 'lib' to its path,
|
|
# ### as the Build.PL would do as well, but the API doesn't.
|
|
# ### this makes self updates possible
|
|
# return $self->module eq 'Module::Build'
|
|
# ? 'lib'
|
|
# : CPANPLUS::inc->installer_path;
|
|
# }
|
|
|
|
### otherwise, the path was found through a 'normal' way of
|
|
### scanning @INC.
|
|
return;
|
|
}
|
|
|
|
=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.
|
|
|
|
=cut
|
|
|
|
# Local variables:
|
|
# c-indentation-style: bsd
|
|
# c-basic-offset: 4
|
|
# indent-tabs-mode: nil
|
|
# End:
|
|
# vim: expandtab shiftwidth=4:
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
todo:
|
|
reports();
|