556 lines
15 KiB
Perl
556 lines
15 KiB
Perl
package CPANPLUS::Internals;
|
|
|
|
### we /need/ perl5.6.1 or higher -- we use coderefs in @INC,
|
|
### and 5.6.0 is just too buggy
|
|
use 5.006001;
|
|
|
|
use strict;
|
|
use Config;
|
|
|
|
use CPANPLUS::Error;
|
|
|
|
use CPANPLUS::Selfupdate;
|
|
|
|
use CPANPLUS::Internals::Extract;
|
|
use CPANPLUS::Internals::Fetch;
|
|
use CPANPLUS::Internals::Utils;
|
|
use CPANPLUS::Internals::Constants;
|
|
use CPANPLUS::Internals::Search;
|
|
use CPANPLUS::Internals::Report;
|
|
|
|
require base;
|
|
use Cwd qw[cwd];
|
|
use Module::Load qw[load];
|
|
use Params::Check qw[check];
|
|
use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
|
|
use Module::Load::Conditional qw[can_load];
|
|
|
|
use Object::Accessor;
|
|
|
|
local $Params::Check::VERBOSE = 1;
|
|
|
|
use vars qw[@ISA $VERSION];
|
|
|
|
@ISA = qw[
|
|
CPANPLUS::Internals::Extract
|
|
CPANPLUS::Internals::Fetch
|
|
CPANPLUS::Internals::Utils
|
|
CPANPLUS::Internals::Search
|
|
CPANPLUS::Internals::Report
|
|
];
|
|
|
|
$VERSION = "0.9910";
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
CPANPLUS::Internals - CPANPLUS internals
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
my $internals = CPANPLUS::Internals->_init( _conf => $conf );
|
|
my $backend = CPANPLUS::Internals->_retrieve_id( $ID );
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module is the guts of CPANPLUS -- it inherits from all other
|
|
modules in the CPANPLUS::Internals::* namespace, thus defying normal
|
|
rules of OO programming -- but if you're reading this, you already
|
|
know what's going on ;)
|
|
|
|
Please read the C<CPANPLUS::Backend> documentation for the normal API.
|
|
|
|
=head1 ACCESSORS
|
|
|
|
=over 4
|
|
|
|
=item _conf
|
|
|
|
Get/set the configure object
|
|
|
|
=item _id
|
|
|
|
Get/set the id
|
|
|
|
=cut
|
|
|
|
### autogenerate accessors ###
|
|
for my $key ( qw[_conf _id _modules _hosts _methods _status _path
|
|
_callbacks _selfupdate _mtree _atree]
|
|
) {
|
|
no strict 'refs';
|
|
*{__PACKAGE__."::$key"} = sub {
|
|
$_[0]->{$key} = $_[1] if @_ > 1;
|
|
return $_[0]->{$key};
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=back
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 $internals = CPANPLUS::Internals->_init( _conf => CONFIG_OBJ )
|
|
|
|
C<_init> creates a new CPANPLUS::Internals object.
|
|
|
|
You have to pass it a valid C<CPANPLUS::Configure> object.
|
|
|
|
Returns the object on success, or dies on failure.
|
|
|
|
=cut
|
|
|
|
{ ### NOTE:
|
|
### if extra callbacks are added, don't forget to update the
|
|
### 02-internals.t test script with them!
|
|
my $callback_map = {
|
|
### name default value
|
|
install_prerequisite => 1, # install prereqs when 'ask' is set?
|
|
edit_test_report => 0, # edit the prepared test report?
|
|
send_test_report => 1, # send the test report?
|
|
# munge the test report
|
|
munge_test_report => sub { return $_[1] },
|
|
# filter out unwanted prereqs
|
|
filter_prereqs => sub { return $_[1] },
|
|
# continue if 'make test' fails?
|
|
proceed_on_test_failure => sub { return 0 },
|
|
munge_dist_metafile => sub { return $_[1] },
|
|
};
|
|
|
|
my $status = Object::Accessor->new;
|
|
$status->mk_accessors(qw[pending_prereqs]);
|
|
|
|
my $callback = Object::Accessor->new;
|
|
$callback->mk_accessors(keys %$callback_map);
|
|
|
|
my $conf;
|
|
my $Tmpl = {
|
|
_conf => { required => 1, store => \$conf,
|
|
allow => IS_CONFOBJ },
|
|
_id => { default => '', no_override => 1 },
|
|
_authortree => { default => '', no_override => 1 },
|
|
_modtree => { default => '', no_override => 1 },
|
|
_hosts => { default => {}, no_override => 1 },
|
|
_methods => { default => {}, no_override => 1 },
|
|
_status => { default => '<empty>', no_override => 1 },
|
|
_callbacks => { default => '<empty>', no_override => 1 },
|
|
_path => { default => $ENV{PATH} || '', no_override => 1 },
|
|
};
|
|
|
|
sub _init {
|
|
my $class = shift;
|
|
my %hash = @_;
|
|
|
|
### temporary warning until we fix the storing of multiple id's
|
|
### and their serialization:
|
|
### probably not going to happen --kane
|
|
if( my $id = $class->_last_id ) {
|
|
# make it a singleton.
|
|
warn loc(q[%1 currently only supports one %2 object per ] .
|
|
qq[running program\n], 'CPANPLUS', $class);
|
|
|
|
return $class->_retrieve_id( $id );
|
|
}
|
|
|
|
my $args = check($Tmpl, \%hash)
|
|
or die loc(qq[Could not initialize '%1' object], $class);
|
|
|
|
bless $args, $class;
|
|
|
|
$args->{'_id'} = $args->_inc_id;
|
|
$args->{'_status'} = $status;
|
|
$args->{'_callbacks'} = $callback;
|
|
|
|
### initialize callbacks to default state ###
|
|
for my $name ( $callback->ls_accessors ) {
|
|
my $rv = ref $callback_map->{$name} ? 'sub return value' :
|
|
$callback_map->{$name} ? 'true' : 'false';
|
|
|
|
$args->_callbacks->$name(
|
|
sub { msg(loc("DEFAULT '%1' HANDLER RETURNING '%2'",
|
|
$name, $rv), $args->_conf->get_conf('debug'));
|
|
return ref $callback_map->{$name}
|
|
? $callback_map->{$name}->( @_ )
|
|
: $callback_map->{$name};
|
|
}
|
|
);
|
|
}
|
|
|
|
### create a selfupdate object
|
|
$args->_selfupdate( CPANPLUS::Selfupdate->new( $args ) );
|
|
|
|
### initialize it as an empty hashref ###
|
|
$args->_status->pending_prereqs( {} );
|
|
|
|
$conf->_set_build( startdir => cwd() ),
|
|
or error( loc("couldn't locate current dir!") );
|
|
|
|
$ENV{FTP_PASSIVE} = 1, if $conf->get_conf('passive');
|
|
|
|
my $id = $args->_store_id( $args );
|
|
|
|
unless ( $id == $args->_id ) {
|
|
error( loc("IDs do not match: %1 != %2. Storage failed!",
|
|
$id, $args->_id) );
|
|
}
|
|
|
|
### different source engines available now, so set them here
|
|
{ my $store = $conf->get_conf( 'source_engine' )
|
|
|| DEFAULT_SOURCE_ENGINE;
|
|
|
|
unless( can_load( modules => { $store => '0.0' }, verbose => 1 ) ) {
|
|
error( loc( "Could not load source engine '%1'", $store ) );
|
|
|
|
if( $store ne DEFAULT_SOURCE_ENGINE ) {
|
|
msg( loc("Falling back to %1", DEFAULT_SOURCE_ENGINE), 1 );
|
|
|
|
load DEFAULT_SOURCE_ENGINE;
|
|
|
|
base->import( DEFAULT_SOURCE_ENGINE );
|
|
} else {
|
|
return;
|
|
}
|
|
} else {
|
|
base->import( $store );
|
|
}
|
|
}
|
|
|
|
return $args;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $internals->_flush( list => \@caches )
|
|
|
|
Flushes the designated caches from the C<CPANPLUS> object.
|
|
|
|
Returns true on success, false if one or more caches could not be
|
|
be flushed.
|
|
|
|
=cut
|
|
|
|
sub _flush {
|
|
my $self = shift;
|
|
my $conf = $self->configure_object;
|
|
my %hash = @_;
|
|
|
|
my $aref;
|
|
my $tmpl = {
|
|
list => { required => 1, default => [],
|
|
strict_type => 1, store => \$aref },
|
|
};
|
|
|
|
my $args = check( $tmpl, \%hash ) or return;
|
|
|
|
my $flag = 0;
|
|
for my $what (@$aref) {
|
|
my $cache = '_' . $what;
|
|
|
|
### set the include paths back to their original ###
|
|
if( $what eq 'lib' ) {
|
|
$ENV{PERL5LIB} = $conf->_perl5lib || '';
|
|
@INC = @{$conf->_lib};
|
|
$ENV{PATH} = $self->_path || '';
|
|
|
|
### give all modules a new status object -- this is slightly
|
|
### costly, but the best way to make sure all statuses are
|
|
### forgotten --kane
|
|
} elsif ( $what eq 'modules' ) {
|
|
for my $modobj ( values %{$self->module_tree} ) {
|
|
|
|
$modobj->_flush;
|
|
}
|
|
|
|
### blow away the methods cache... currently, that's only
|
|
### File::Fetch's method fail list
|
|
} elsif ( $what eq 'methods' ) {
|
|
|
|
### still unbelievably p4 :( ###
|
|
$File::Fetch::METHOD_FAIL = $File::Fetch::METHOD_FAIL = {};
|
|
|
|
### blow away the m::l::c cache, so modules can be (re)loaded
|
|
### again if they become available
|
|
} elsif ( $what eq 'load' ) {
|
|
undef $Module::Load::Conditional::CACHE;
|
|
|
|
} else {
|
|
unless ( exists $self->{$cache} && exists $Tmpl->{$cache} ) {
|
|
error( loc( "No such cache: '%1'", $what ) );
|
|
$flag++;
|
|
next;
|
|
} else {
|
|
$self->$cache( {} );
|
|
}
|
|
}
|
|
}
|
|
return !$flag;
|
|
}
|
|
|
|
### NOTE:
|
|
### if extra callbacks are added, don't forget to update the
|
|
### 02-internals.t test script with them!
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $internals->_register_callback( name => CALLBACK_NAME, code => CODEREF );
|
|
|
|
Registers a callback for later use by the internal libraries.
|
|
|
|
Here is a list of the currently used callbacks:
|
|
|
|
=over 4
|
|
|
|
=item install_prerequisite
|
|
|
|
Is called when the user wants to be C<asked> about what to do with
|
|
prerequisites. Should return a boolean indicating true to install
|
|
the prerequisite and false to skip it.
|
|
|
|
=item send_test_report
|
|
|
|
Is called when the user should be prompted if he wishes to send the
|
|
test report. Should return a boolean indicating true to send the
|
|
test report and false to skip it.
|
|
|
|
=item munge_test_report
|
|
|
|
Is called when the test report message has been composed, giving
|
|
the user a chance to programmatically alter it. Should return the
|
|
(munged) message to be sent.
|
|
|
|
=item edit_test_report
|
|
|
|
Is called when the user should be prompted to edit test reports
|
|
about to be sent out by Test::Reporter. Should return a boolean
|
|
indicating true to edit the test report in an editor and false
|
|
to skip it.
|
|
|
|
=item proceed_on_test_failure
|
|
|
|
Is called when 'make test' or 'Build test' fails. Should return
|
|
a boolean indicating whether the install should continue even if
|
|
the test failed.
|
|
|
|
=item munge_dist_metafile
|
|
|
|
Is called when the C<CPANPLUS::Dist::*> metafile is created, like
|
|
C<control> for C<CPANPLUS::Dist::Deb>, giving the user a chance to
|
|
programmatically alter it. Should return the (munged) text to be
|
|
written to the metafile.
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub _register_callback {
|
|
my $self = shift or return;
|
|
my %hash = @_;
|
|
|
|
my ($name,$code);
|
|
my $tmpl = {
|
|
name => { required => 1, store => \$name,
|
|
allow => [$callback->ls_accessors] },
|
|
code => { required => 1, allow => IS_CODEREF,
|
|
store => \$code },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
$self->_callbacks->$name( $code ) or return;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# =head2 $bool = $internals->_add_callback( name => CALLBACK_NAME, code => CODEREF );
|
|
#
|
|
# Adds a new callback to be used from anywhere in the system. If the callback
|
|
# is already known, an error is raised and false is returned. If the callback
|
|
# is not yet known, it is added, and the corresponding coderef is registered
|
|
# using the
|
|
#
|
|
# =cut
|
|
#
|
|
# sub _add_callback {
|
|
# my $self = shift or return;
|
|
# my %hash = @_;
|
|
#
|
|
# my ($name,$code);
|
|
# my $tmpl = {
|
|
# name => { required => 1, store => \$name, },
|
|
# code => { required => 1, allow => IS_CODEREF,
|
|
# store => \$code },
|
|
# };
|
|
#
|
|
# check( $tmpl, \%hash ) or return;
|
|
#
|
|
# if( $callback->can( $name ) ) {
|
|
# error(loc("Callback '%1' is already registered"));
|
|
# return;
|
|
# }
|
|
#
|
|
# $callback->mk_accessor( $name );
|
|
#
|
|
# $self->_register_callback( name => $name, code => $code ) or return;
|
|
#
|
|
# return 1;
|
|
# }
|
|
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $internals->_add_to_includepath( directories => \@dirs )
|
|
|
|
Adds a list of directories to the include path.
|
|
This means they get added to C<@INC> as well as C<$ENV{PERL5LIB}>.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub _add_to_includepath {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $dirs;
|
|
my $tmpl = {
|
|
directories => { required => 1, default => [], store => \$dirs,
|
|
strict_type => 1 },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
my $s = $Config{'path_sep'};
|
|
|
|
### only add if it's not added yet
|
|
for my $lib (@$dirs) {
|
|
unshift @INC, $lib unless grep { $_ eq $lib } @INC;
|
|
#
|
|
### it will be complaining if $ENV{PERL5LIB] is not defined (yet).
|
|
local $^W;
|
|
$ENV{'PERL5LIB'} .= $s . $lib
|
|
unless $ENV{'PERL5LIB'} =~ qr|\Q$s$lib\E|;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $bool = $internals->_add_to_path( directories => \@dirs )
|
|
|
|
Adds a list of directories to the PATH, but only if they actually
|
|
contain anything.
|
|
|
|
Returns true on success, false on failure.
|
|
|
|
=cut
|
|
|
|
sub _add_to_path {
|
|
my $self = shift;
|
|
my %hash = @_;
|
|
|
|
my $dirs;
|
|
my $tmpl = {
|
|
directories => { required => 1, default => [], store => \$dirs,
|
|
strict_type => 1 },
|
|
};
|
|
|
|
check( $tmpl, \%hash ) or return;
|
|
|
|
my $s = $Config{'path_sep'};
|
|
|
|
require File::Glob;
|
|
|
|
### only add if it's not added yet
|
|
for my $dir (@$dirs) {
|
|
$dir =~ s![\\/]*$!!g;
|
|
next if $ENV{PATH} =~ qr|\Q$dir\E|;
|
|
next unless -d $dir;
|
|
next unless File::Glob::bsd_glob( $dir . q{/*} );
|
|
$ENV{PATH} = join $s, $dir, $ENV{PATH};
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 $id = CPANPLUS::Internals->_last_id
|
|
|
|
Return the id of the last object stored.
|
|
|
|
=head2 $id = CPANPLUS::Internals->_store_id( $internals )
|
|
|
|
Store this object; return its id.
|
|
|
|
=head2 $obj = CPANPLUS::Internals->_retrieve_id( $ID )
|
|
|
|
Retrieve an object based on its ID -- return false on error.
|
|
|
|
=head2 CPANPLUS::Internals->_remove_id( $ID )
|
|
|
|
Remove the object marked by $ID from storage.
|
|
|
|
=head2 @objs = CPANPLUS::Internals->_return_all_objects
|
|
|
|
Return all stored objects.
|
|
|
|
=cut
|
|
|
|
|
|
### code for storing multiple objects
|
|
### -- although we only support one right now
|
|
### XXX when support for multiple objects comes, saving source will have
|
|
### to change
|
|
{
|
|
my $idref = {};
|
|
my $count = 0;
|
|
|
|
sub _inc_id { return ++$count; }
|
|
|
|
sub _last_id { $count }
|
|
|
|
sub _store_id {
|
|
my $self = shift;
|
|
my $obj = shift or return;
|
|
|
|
unless( IS_INTERNALS_OBJ->($obj) ) {
|
|
error( loc("The object you passed has the wrong ref type: '%1'",
|
|
ref $obj) );
|
|
return;
|
|
}
|
|
|
|
$idref->{ $obj->_id } = $obj;
|
|
return $obj->_id;
|
|
}
|
|
|
|
sub _retrieve_id {
|
|
my $self = shift;
|
|
my $id = shift or return;
|
|
|
|
my $obj = $idref->{$id};
|
|
return $obj;
|
|
}
|
|
|
|
sub _remove_id {
|
|
my $self = shift;
|
|
my $id = shift or return;
|
|
|
|
return delete $idref->{$id};
|
|
}
|
|
|
|
sub _return_all_objects { return values %$idref }
|
|
}
|
|
|
|
1;
|
|
|
|
# Local variables:
|
|
# c-indentation-style: bsd
|
|
# c-basic-offset: 4
|
|
# indent-tabs-mode: nil
|
|
# End:
|
|
# vim: expandtab shiftwidth=4:
|