summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm1815
1 files changed, 1815 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm
new file mode 100644
index 00000000000..9e4b67e4a38
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Module.pm
@@ -0,0 +1,1815 @@
+package CPANPLUS::Module;
+
+use strict;
+use vars qw[@ISA];
+
+
+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
+
+=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 ($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 = $Module::CoreList::version{ 0+$ver }->{ $name };
+
+ 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 dont 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;
+ }
+
+ ### 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.24' )
+ ) ) {
+
+ ### 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.24', %$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 dont 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' succesfully bootstrapped", $type));
+ }
+
+ ### some other plugin you dont 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 upto date ###
+ 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;
+ }
+
+ $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 @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,
+ @_,
+ );
+
+ 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 doensn'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.
+
+You can reset C<@INC> and C<$PERL5LIB> to its 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;
+
+ } 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();