[perl5.git] / lib / CPANPLUS / Selfupdate.pm

package CPANPLUS::Selfupdate;

use strict;
use Params::Check               qw[check];
use IPC::Cmd                    qw[can_run];
use CPANPLUS::Error             qw[error msg];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

use CPANPLUS::Internals::Constants;

$Params::Check::VERBOSE = 1;

=head1 NAME

CPANPLUS::Selfupdate

=head1 SYNOPSIS

    $su     = $cb->selfupdate_object;
    
    @feats  = $su->list_features;
    @feats  = $su->list_enabled_features;
    
    @mods   = map { $su->modules_for_feature( $_ ) } @feats;
    @mods   = $su->list_core_dependencies;
    @mods   = $su->list_core_modules;
    
    for ( @mods ) {
        print $_->name " should be version " . $_->version_required;
        print "Installed version is not uptodate!" 
            unless $_->is_installed_version_sufficient;
    }
    
    $ok     = $su->selfupdate( update => 'all', latest => 0 );

=cut

### a config has describing our deps etc
{

    my $Modules = {
        dependencies => {
            'File::Fetch'               => '0.15_02', # lynx & 404 handling
            'File::Spec'                => '0.82',
            'IPC::Cmd'                  => '0.36', # 5.6.2 compat: 2-arg open
            'Locale::Maketext::Simple'  => '0.01',
            'Log::Message'              => '0.01',
            'Module::Load'              => '0.10',
            'Module::Load::Conditional' => '0.28', # returns dir for loaded
                                                   # modules
            'version'                   => '0.73', # needed for M::L::C
                                                   # addresses #24630 and 
                                                   # #24675
                                                   # Address ~0 overflow issue
            'Params::Check'             => '0.22',
            'Package::Constants'        => '0.01',
            'Term::UI'                  => '0.18', # option parsing
            'Test::Harness'             => '2.62', # due to bug #19505
                                                   # only 2.58 and 2.60 are bad
            'Test::More'                => '0.47', # to run our tests
            'Archive::Extract'          => '0.16', # ./Dir bug fix
            'Archive::Tar'              => '1.23',
            'IO::Zlib'                  => '1.04', # needed for Archive::Tar
            'Object::Accessor'          => '0.34', # mk_aliases support
            'Module::CoreList'          => '2.09',
            'Module::Pluggable'         => '2.4',
            'Module::Loaded'            => '0.01',
            'Parse::CPAN::Meta'         => '0.02', # config_requires support
            'ExtUtils::Install'         => '1.42', # uninstall outside @INC
        },
    
        features => {
            # config_key_name => [
            #     sub { } to list module key/value pairs
            #     sub { } to check if feature is enabled
            # ]
            prefer_makefile => [
                sub {
                    my $cb = shift;
                    $cb->configure_object->get_conf('prefer_makefile') 
                        ? { }
                        : { 'CPANPLUS::Dist::Build' => '0.24'  };
                },
                sub { return 1 },   # always enabled
            ],            
            cpantest        => [
                { 'Test::Reporter'  => '1.34',
                  'YAML::Tiny'      => '0.0'
                },
                sub { 
                    my $cb = shift;
                    return $cb->configure_object->get_conf('cpantest');
                },
            ],                
            dist_type => [
                sub { 
                    my $cb      = shift;
                    my $dist    = $cb->configure_object->get_conf('dist_type');
                    return { $dist => '0.0' } if $dist;
                    return;
                },            
                sub { 
                    my $cb = shift;
                    return $cb->configure_object->get_conf('dist_type');
                },
            ],

            md5 => [
                {
                    'Digest::MD5'   => '0.0',
                },            
                sub { 
                    my $cb = shift;
                    return $cb->configure_object->get_conf('md5');
                },
            ],
            shell => [
                sub { 
                    my $cb      = shift;
                    my $dist    = $cb->configure_object->get_conf('shell');
                    
                    ### we bundle these shells, so don't bother having a dep
                    ### on them... If we don't do this, CPAN.pm actually detects
                    ### a recursive dependency and breaks (see #26077).
                    ### This is not an issue for CPANPLUS itself, it handles
                    ### it smartly.
                    return if $dist eq SHELL_DEFAULT or $dist eq SHELL_CLASSIC;
                    return { $dist => '0.0' } if $dist;
                    return;
                },            
                sub { return 1 },
            ],                
            signature => [
                sub {
                    my $cb      = shift;
                    return {
                        'Module::Signature' => '0.06',
                    } if can_run('gpg');
                    ### leave this out -- Crypt::OpenPGP is fairly
                    ### painful to install, and broken on some platforms
                    ### so we'll just always fall back to gpg. It may
                    ### issue a warning or 2, but that's about it.
                    ### this change due to this ticket: #26914
                    # and $cb->configure_object->get_conf('prefer_bin');

                    return { 
                        'Crypt::OpenPGP'    => '0.0', 
                        'Module::Signature' => '0.06',
                    };
                },            
                sub {
                    my $cb = shift;
                    return $cb->configure_object->get_conf('signature');
                },
            ],
            storable => [
                { 'Storable' => '0.0' },         
                sub { 
                    my $cb = shift;
                    return $cb->configure_object->get_conf('storable');
                },
            ],
            sqlite_backend => [
                {   'DBIx::Simple' => '0.0',
                    'DBD::SQLite'  => '0.0',
                },
                sub {
                    my $cb   = shift;
                    my $conf = $cb->configure_object;
                    return $conf->get_conf('source_engine') 
                        eq 'CPANPLUS::Internals::Source::SQLite'
                },                        
            ],                    
        },
        core => {
            'CPANPLUS' => '0.0',
        },
    };

    sub _get_config { return $Modules }
}

=head1 METHODS

=head2 $self = CPANPLUS::Selfupdate->new( $backend_object );

Sets up a new selfupdate object. Called automatically when
a new backend object is created.

=cut

sub new {
    my $class = shift;
    my $cb    = shift or return;
    return bless sub { $cb }, $class;
}    


{   ### cache to find the relevant modules
    my $cache = {
        core 
            => sub { my $self = shift;
                     core => [ $self->list_core_modules ]   },
 
        dependencies        
            => sub { my $self = shift;
                     dependencies => [ $self->list_core_dependencies ] },

        enabled_features    
            => sub { my $self = shift;
                     map { $_ => [ $self->modules_for_feature( $_ ) ] }
                        $self->list_enabled_features 
                   },
        features
            => sub { my $self = shift;
                     map { $_ => [ $self->modules_for_feature( $_ ) ] }
                        $self->list_features   
                   },
            ### make sure to do 'core' first, in case
            ### we are out of date ourselves
        all => [ qw|core dependencies enabled_features| ],
    };
    
    
=head2 @cat = $self->list_categories

Returns a list of categories that the C<selfupdate> method accepts.

See C<selfupdate> for details.

=cut

    sub list_categories { return sort keys %$cache }

=head2 %list = $self->list_modules_to_update( update => "core|dependencies|enabled_features|features|all", [latest => BOOL] )
    
List which modules C<selfupdate> would upgrade. You can update either 
the core (CPANPLUS itself), the core dependencies, all features you have
currently turned on, or all features available, or everything.

The C<latest> option determines whether it should update to the latest
version on CPAN, or if the minimal required version for CPANPLUS is
good enough.
    
Returns a hash of feature names and lists of module objects to be
upgraded based on the category you provided. For example:

    %list = $self->list_modules_to_update( update => 'core' );
    
Would return:

    ( core => [ $module_object_for_cpanplus ] );
    
=cut    
    
    sub list_modules_to_update {
        my $self = shift;
        my $cb   = $self->();
        my $conf = $cb->configure_object;
        my %hash = @_;
        
        my($type, $latest);
        my $tmpl = {
            update => { required => 1, store => \$type,
                         allow   => [ keys %$cache ], },
            latest => { default  => 0, store => \$latest, allow => BOOLEANS },                     
        };    
    
        {   local $Params::Check::ALLOW_UNKNOWN = 1;
            check( $tmpl, \%hash ) or return;
        }
    
        my $ref     = $cache->{$type};

        ### a list of ( feature1 => \@mods, feature2 => \@mods, etc )        
        my %list    = UNIVERSAL::isa( $ref, 'ARRAY' )
                            ? map { $cache->{$_}->( $self ) } @$ref
                            : $ref->( $self );

        ### filter based on whether we need the latest ones or not
        for my $aref ( values %list ) {              
              $aref = [ $latest 
                        ? grep { !$_->is_uptodate } @$aref
                        : grep { !$_->is_installed_version_sufficient } @$aref
                      ];
        }
        
        return %list;
    }
    
=head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", [latest => BOOL, force => BOOL] )

Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself),
the core dependencies, all features you have currently turned on, or
all features available, or everything.

The C<latest> option determines whether it should update to the latest
version on CPAN, or if the minimal required version for CPANPLUS is
good enough.

Returns true on success, false on error.

=cut

    sub selfupdate {
        my $self = shift;
        my $cb   = $self->();
        my $conf = $cb->configure_object;
        my %hash = @_;
    
        my $force;
        my $tmpl = {
            force  => { default => $conf->get_conf('force'), store => \$force },
        };    
    
        {   local $Params::Check::ALLOW_UNKNOWN = 1;
            check( $tmpl, \%hash ) or return;
        }
    
        my %list = $self->list_modules_to_update( %hash ) or return;

        ### just the modules please
        my @mods = map { @$_ } values %list;
        
        my $flag;
        for my $mod ( @mods ) {
            unless( $mod->install( force => $force ) ) {
                $flag++;
                error(loc("Failed to update module '%1'", $mod->name));
            }
        }
        
        return if $flag;
        return 1;
    }    

}

=head2 @features = $self->list_features

Returns a list of features that are supported by CPANPLUS.

=cut

sub list_features {
    my $self = shift;
    return keys %{ $self->_get_config->{'features'} };
}

=head2 @features = $self->list_enabled_features

Returns a list of features that are enabled in your current
CPANPLUS installation.

=cut

sub list_enabled_features {
    my $self = shift;
    my $cb   = $self->();
    
    my @enabled;
    for my $feat ( $self->list_features ) {
        my $ref = $self->_get_config->{'features'}->{$feat}->[1];
        push @enabled, $feat if $ref->($cb);
    }
    
    return @enabled;
}

=head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] )

Returns a list of C<CPANPLUS::Selfupdate::Module> objects which 
represent the modules required to support this feature.

For a list of features, call the C<list_features> method.

If the C<AS_HASH> argument is provided, no module objects are
returned, but a hashref where the keys are names of the modules,
and values are their minimum versions.

=cut

sub modules_for_feature {
    my $self    = shift;
    my $feature = shift or return;
    my $as_hash = shift || 0;
    my $cb      = $self->();
    
    unless( exists $self->_get_config->{'features'}->{$feature} ) {
        error(loc("Unknown feature '%1'", $feature));
        return;
    }
    
    my $ref = $self->_get_config->{'features'}->{$feature}->[0];
    
    ### it's either a list of modules/versions or a subroutine that
    ### returns a list of modules/versions
    my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb );
    
    return unless $href;    # nothing needed for the feature?

    return $href if $as_hash;
    return $self->_hashref_to_module( $href );
}


=head2 @mods = $self->list_core_dependencies( [AS_HASH] )

Returns a list of C<CPANPLUS::Selfupdate::Module> objects which 
represent the modules that comprise the core dependencies of CPANPLUS.

If the C<AS_HASH> argument is provided, no module objects are
returned, but a hashref where the keys are names of the modules,
and values are their minimum versions.

=cut

sub list_core_dependencies {
    my $self    = shift;
    my $as_hash = shift || 0;
    my $cb      = $self->();
    my $href    = $self->_get_config->{'dependencies'};

    return $href if $as_hash;
    return $self->_hashref_to_module( $href );
}

=head2 @mods = $self->list_core_modules( [AS_HASH] )

Returns a list of C<CPANPLUS::Selfupdate::Module> objects which 
represent the modules that comprise the core of CPANPLUS.

If the C<AS_HASH> argument is provided, no module objects are
returned, but a hashref where the keys are names of the modules,
and values are their minimum versions.

=cut

sub list_core_modules {
    my $self    = shift;
    my $as_hash = shift || 0;
    my $cb      = $self->();
    my $href    = $self->_get_config->{'core'};

    return $href if $as_hash;
    return $self->_hashref_to_module( $href );
}

sub _hashref_to_module {
    my $self = shift;
    my $cb   = $self->();
    my $href = shift or return;
    
    return map { 
            CPANPLUS::Selfupdate::Module->new(
                $cb->module_tree($_) => $href->{$_}
            )
        } keys %$href;
}        
    

=head1 CPANPLUS::Selfupdate::Module

C<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects
by providing accessors to aid in selfupdating CPANPLUS.

These objects are returned by all methods of C<CPANPLUS::Selfupdate>
that return module objects.

=cut

{   package CPANPLUS::Selfupdate::Module;
    use base 'CPANPLUS::Module';
    
    ### stores module name -> cpanplus required version
    ### XXX only can deal with 1 pair!
    my %Cache = ();
    my $Acc   = 'version_required';
    
    sub new {
        my $class = shift;
        my $mod   = shift or return;
        my $ver   = shift;          return unless defined $ver;
        
        my $obj   = $mod->clone;    # clone the module object
        bless $obj, $class;         # rebless it to our class
        
        $obj->$Acc( $ver );
        
        return $obj;
    }

=head2 $version = $mod->version_required

Returns the version of this module required for CPANPLUS.

=cut
    
    sub version_required {
        my $self = shift;
        $Cache{ $self->name } = shift() if @_;
        return $Cache{ $self->name };
    }        

=head2 $bool = $mod->is_installed_version_sufficient

Returns true if the installed version of this module is sufficient
for CPANPLUS, or false if it is not.

=cut

    
    sub is_installed_version_sufficient {
        my $self = shift;
        return $self->is_uptodate( version => $self->$Acc );
    }

}    

1;

=pod

=head1 BUG REPORTS

Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.

=head1 AUTHOR

This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.

=head1 COPYRIGHT

The CPAN++ interface (of which this module is a part of) is copyright (c) 
2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.

This library is free software; you may redistribute and/or modify it 
under the same terms as Perl itself.

=cut

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
Commit	Line	Data
6aaee015 RGS	1	package CPANPLUS::Selfupdate;
	2
	3	use strict;
	4	use Params::Check qw[check];
	5	use IPC::Cmd qw[can_run];
	6	use CPANPLUS::Error qw[error msg];
	7	use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
	8
	9	use CPANPLUS::Internals::Constants;
	10
	11	$Params::Check::VERBOSE = 1;
	12
	13	=head1 NAME
	14
	15	CPANPLUS::Selfupdate
	16
	17	=head1 SYNOPSIS
	18
	19	$su = $cb->selfupdate_object;
	20
	21	@feats = $su->list_features;
	22	@feats = $su->list_enabled_features;
	23
	24	@mods = map { $su->modules_for_feature( $_ ) } @feats;
	25	@mods = $su->list_core_dependencies;
	26	@mods = $su->list_core_modules;
	27
	28	for ( @mods ) {
	29	print $_->name " should be version " . $_->version_required;
	30	print "Installed version is not uptodate!"
	31	unless $_->is_installed_version_sufficient;
	32	}
	33
	34	$ok = $su->selfupdate( update => 'all', latest => 0 );
	35
	36	=cut
	37
	38	### a config has describing our deps etc
	39	{
	40
	41	my $Modules = {
	42	dependencies => {
4443dd53	43	'File::Fetch' => '0.15_02', # lynx & 404 handling
6aaee015 RGS	44	'File::Spec' => '0.82',
	45	'IPC::Cmd' => '0.36', # 5.6.2 compat: 2-arg open
	46	'Locale::Maketext::Simple' => '0.01',
	47	'Log::Message' => '0.01',
	48	'Module::Load' => '0.10',
4443dd53 JB	49	'Module::Load::Conditional' => '0.28', # returns dir for loaded
4443dd53 JB	50	# modules
5879cbe1	51	'version' => '0.73', # needed for M::L::C
6aaee015 RGS	52	# addresses #24630 and
6aaee015 RGS	53	# #24675
5879cbe1	54	# Address ~0 overflow issue
6aaee015 RGS	55	'Params::Check' => '0.22',
6aaee015 RGS	56	'Package::Constants' => '0.01',
0fe18d46	57	'Term::UI' => '0.18', # option parsing
6aaee015 RGS	58	'Test::Harness' => '2.62', # due to bug #19505
	59	# only 2.58 and 2.60 are bad
	60	'Test::More' => '0.47', # to run our tests
	61	'Archive::Extract' => '0.16', # ./Dir bug fix
	62	'Archive::Tar' => '1.23',
	63	'IO::Zlib' => '1.04', # needed for Archive::Tar
4443dd53	64	'Object::Accessor' => '0.34', # mk_aliases support
6aaee015 RGS	65	'Module::CoreList' => '2.09',
	66	'Module::Pluggable' => '2.4',
	67	'Module::Loaded' => '0.01',
4443dd53 JB	68	'Parse::CPAN::Meta' => '0.02', # config_requires support
4443dd53 JB	69	'ExtUtils::Install' => '1.42', # uninstall outside @INC
6aaee015 RGS	70	},
	71
	72	features => {
	73	# config_key_name => [
	74	# sub { } to list module key/value pairs
	75	# sub { } to check if feature is enabled
	76	# ]
	77	prefer_makefile => [
	78	sub {
	79	my $cb = shift;
	80	$cb->configure_object->get_conf('prefer_makefile')
	81	? { }
02f445e1	82	: { 'CPANPLUS::Dist::Build' => '0.24' };
6aaee015 RGS	83	},
	84	sub { return 1 }, # always enabled
	85	],
	86	cpantest => [
4443dd53 JB	87	{ 'Test::Reporter' => '1.34',
4443dd53 JB	88	'YAML::Tiny' => '0.0'
6aaee015 RGS	89	},
	90	sub {
	91	my $cb = shift;
	92	return $cb->configure_object->get_conf('cpantest');
	93	},
	94	],
	95	dist_type => [
	96	sub {
	97	my $cb = shift;
	98	my $dist = $cb->configure_object->get_conf('dist_type');
	99	return { $dist => '0.0' } if $dist;
	100	return;
	101	},
	102	sub {
	103	my $cb = shift;
	104	return $cb->configure_object->get_conf('dist_type');
	105	},
	106	],
	107
	108	md5 => [
	109	{
	110	'Digest::MD5' => '0.0',
	111	},
	112	sub {
	113	my $cb = shift;
	114	return $cb->configure_object->get_conf('md5');
	115	},
	116	],
	117	shell => [
	118	sub {
	119	my $cb = shift;
	120	my $dist = $cb->configure_object->get_conf('shell');
494f1016 JB	121
	122	### we bundle these shells, so don't bother having a dep
	123	### on them... If we don't do this, CPAN.pm actually detects
	124	### a recursive dependency and breaks (see #26077).
	125	### This is not an issue for CPANPLUS itself, it handles
	126	### it smartly.
	127	return if $dist eq SHELL_DEFAULT or $dist eq SHELL_CLASSIC;
6aaee015 RGS	128	return { $dist => '0.0' } if $dist;
	129	return;
	130	},
	131	sub { return 1 },
	132	],
	133	signature => [
	134	sub {
	135	my $cb = shift;
502c7995 JB	136	return {
	137	'Module::Signature' => '0.06',
	138	} if can_run('gpg');
	139	### leave this out -- Crypt::OpenPGP is fairly
	140	### painful to install, and broken on some platforms
	141	### so we'll just always fall back to gpg. It may
	142	### issue a warning or 2, but that's about it.
	143	### this change due to this ticket: #26914
	144	# and $cb->configure_object->get_conf('prefer_bin');
	145
	146	return {
	147	'Crypt::OpenPGP' => '0.0',
	148	'Module::Signature' => '0.06',
	149	};
6aaee015	150	},
e3b7d412	151	sub {
6aaee015 RGS	152	my $cb = shift;
	153	return $cb->configure_object->get_conf('signature');
	154	},
	155	],
	156	storable => [
	157	{ 'Storable' => '0.0' },
	158	sub {
	159	my $cb = shift;
	160	return $cb->configure_object->get_conf('storable');
	161	},
	162	],
4443dd53 JB	163	sqlite_backend => [
	164	{ 'DBIx::Simple' => '0.0',
	165	'DBD::SQLite' => '0.0',
	166	},
	167	sub {
	168	my $cb = shift;
	169	my $conf = $cb->configure_object;
	170	return $conf->get_conf('source_engine')
	171	eq 'CPANPLUS::Internals::Source::SQLite'
	172	},
	173	],
6aaee015 RGS	174	},
	175	core => {
	176	'CPANPLUS' => '0.0',
	177	},
	178	};
	179
	180	sub _get_config { return $Modules }
	181	}
	182
	183	=head1 METHODS
	184
	185	=head2 $self = CPANPLUS::Selfupdate->new( $backend_object );
	186
	187	Sets up a new selfupdate object. Called automatically when
	188	a new backend object is created.
	189
	190	=cut
	191
	192	sub new {
	193	my $class = shift;
	194	my $cb = shift or return;
	195	return bless sub { $cb }, $class;
	196	}
	197
	198
622d31ac JB	199	{ ### cache to find the relevant modules
	200	my $cache = {
	201	core
	202	=> sub { my $self = shift;
	203	core => [ $self->list_core_modules ] },
	204
	205	dependencies
	206	=> sub { my $self = shift;
	207	dependencies => [ $self->list_core_dependencies ] },
	208
	209	enabled_features
	210	=> sub { my $self = shift;
	211	map { $_ => [ $self->modules_for_feature( $_ ) ] }
	212	$self->list_enabled_features
	213	},
	214	features
	215	=> sub { my $self = shift;
	216	map { $_ => [ $self->modules_for_feature( $_ ) ] }
	217	$self->list_features
	218	},
	219	### make sure to do 'core' first, in case
	220	### we are out of date ourselves
	221	all => [ qw\|core dependencies enabled_features\| ],
	222	};
	223
	224
	225	=head2 @cat = $self->list_categories
	226
	227	Returns a list of categories that the C<selfupdate> method accepts.
	228
	229	See C<selfupdate> for details.
	230
	231	=cut
	232
	233	sub list_categories { return sort keys %$cache }
	234
	235	=head2 %list = $self->list_modules_to_update( update => "core\|dependencies\|enabled_features\|features\|all", [latest => BOOL] )
	236
	237	List which modules C<selfupdate> would upgrade. You can update either
	238	the core (CPANPLUS itself), the core dependencies, all features you have
	239	currently turned on, or all features available, or everything.
	240
	241	The C<latest> option determines whether it should update to the latest
	242	version on CPAN, or if the minimal required version for CPANPLUS is
	243	good enough.
	244
	245	Returns a hash of feature names and lists of module objects to be
	246	upgraded based on the category you provided. For example:
	247
	248	%list = $self->list_modules_to_update( update => 'core' );
	249
	250	Would return:
	251
	252	( core => [ $module_object_for_cpanplus ] );
	253
	254	=cut
	255
	256	sub list_modules_to_update {
	257	my $self = shift;
	258	my $cb = $self->();
	259	my $conf = $cb->configure_object;
	260	my %hash = @_;
	261
	262	my($type, $latest);
263	my $tmpl = {
264	update => { required => 1, store => \$type,
265	allow => [ keys %$cache ], },
266	latest => { default => 0, store => \$latest, allow => BOOLEANS },
267	};
268
269	{ local $Params::Check::ALLOW_UNKNOWN = 1;
270	check( $tmpl, \%hash ) or return;
271	}
272
273	my $ref = $cache->{$type};
6aaee015	274
622d31ac JB	275	### a list of ( feature1 => \@mods, feature2 => \@mods, etc )
	276	my %list = UNIVERSAL::isa( $ref, 'ARRAY' )
	277	? map { $cache->{$_}->( $self ) } @$ref
	278	: $ref->( $self );
	279
	280	### filter based on whether we need the latest ones or not
	281	for my $aref ( values %list ) {
	282	$aref = [ $latest
	283	? grep { !$_->is_uptodate } @$aref
	284	: grep { !$_->is_installed_version_sufficient } @$aref
	285	];
	286	}
	287
	288	return %list;
	289	}
	290
	291	=head2 $bool = $self->selfupdate( update => "core\|dependencies\|enabled_features\|features\|all", [latest => BOOL, force => BOOL] )
6aaee015 RGS	292
	293	Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself),
	294	the core dependencies, all features you have currently turned on, or
	295	all features available, or everything.
	296
	297	The C<latest> option determines whether it should update to the latest
	298	version on CPAN, or if the minimal required version for CPANPLUS is
	299	good enough.
	300
	301	Returns true on success, false on error.
	302
	303	=cut
	304
622d31ac JB	305	sub selfupdate {
	306	my $self = shift;
	307	my $cb = $self->();
	308	my $conf = $cb->configure_object;
	309	my %hash = @_;
6aaee015	310
622d31ac JB	311	my $force;
	312	my $tmpl = {
	313	force => { default => $conf->get_conf('force'), store => \$force },
	314	};
6aaee015	315
622d31ac JB	316	{ local $Params::Check::ALLOW_UNKNOWN = 1;
622d31ac JB	317	check( $tmpl, \%hash ) or return;
6aaee015	318	}
6aaee015	319
622d31ac JB	320	my %list = $self->list_modules_to_update( %hash ) or return;
	321
	322	### just the modules please
	323	my @mods = map { @$_ } values %list;
	324
	325	my $flag;
	326	for my $mod ( @mods ) {
	327	unless( $mod->install( force => $force ) ) {
	328	$flag++;
	329	error(loc("Failed to update module '%1'", $mod->name));
	330	}
	331	}
	332
	333	return if $flag;
	334	return 1;
	335	}
	336
	337	}
6aaee015 RGS	338
	339	=head2 @features = $self->list_features
	340
	341	Returns a list of features that are supported by CPANPLUS.
	342
	343	=cut
	344
	345	sub list_features {
	346	my $self = shift;
	347	return keys %{ $self->_get_config->{'features'} };
	348	}
	349
	350	=head2 @features = $self->list_enabled_features
	351
	352	Returns a list of features that are enabled in your current
	353	CPANPLUS installation.
	354
	355	=cut
	356
	357	sub list_enabled_features {
	358	my $self = shift;
	359	my $cb = $self->();
	360
	361	my @enabled;
	362	for my $feat ( $self->list_features ) {
	363	my $ref = $self->_get_config->{'features'}->{$feat}->[1];
	364	push @enabled, $feat if $ref->($cb);
	365	}
	366
	367	return @enabled;
	368	}
	369
	370	=head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] )
	371
	372	Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
	373	represent the modules required to support this feature.
	374
	375	For a list of features, call the C<list_features> method.
	376
	377	If the C<AS_HASH> argument is provided, no module objects are
	378	returned, but a hashref where the keys are names of the modules,
	379	and values are their minimum versions.
	380
	381	=cut
	382
	383	sub modules_for_feature {
	384	my $self = shift;
	385	my $feature = shift or return;
	386	my $as_hash = shift \|\| 0;
	387	my $cb = $self->();
	388
	389	unless( exists $self->_get_config->{'features'}->{$feature} ) {
	390	error(loc("Unknown feature '%1'", $feature));
	391	return;
	392	}
	393
	394	my $ref = $self->_get_config->{'features'}->{$feature}->[0];
	395
	396	### it's either a list of modules/versions or a subroutine that
	397	### returns a list of modules/versions
	398	my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb );
	399
	400	return unless $href; # nothing needed for the feature?
	401
402	return $href if $as_hash;
403	return $self->_hashref_to_module( $href );
404	}
405
406
407	=head2 @mods = $self->list_core_dependencies( [AS_HASH] )
408
409	Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
410	represent the modules that comprise the core dependencies of CPANPLUS.
411
412	If the C<AS_HASH> argument is provided, no module objects are
413	returned, but a hashref where the keys are names of the modules,
414	and values are their minimum versions.
415
416	=cut
417
418	sub list_core_dependencies {
419	my $self = shift;
420	my $as_hash = shift \|\| 0;
421	my $cb = $self->();
422	my $href = $self->_get_config->{'dependencies'};
423
424	return $href if $as_hash;
425	return $self->_hashref_to_module( $href );
426	}
427
428	=head2 @mods = $self->list_core_modules( [AS_HASH] )
429
430	Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
431	represent the modules that comprise the core of CPANPLUS.
432
433	If the C<AS_HASH> argument is provided, no module objects are
434	returned, but a hashref where the keys are names of the modules,
435	and values are their minimum versions.
436
437	=cut
438
439	sub list_core_modules {
440	my $self = shift;
441	my $as_hash = shift \|\| 0;
442	my $cb = $self->();
443	my $href = $self->_get_config->{'core'};
444
445	return $href if $as_hash;
446	return $self->_hashref_to_module( $href );
447	}
448
449	sub _hashref_to_module {
450	my $self = shift;
451	my $cb = $self->();
452	my $href = shift or return;
453
454	return map {
455	CPANPLUS::Selfupdate::Module->new(
456	$cb->module_tree($_) => $href->{$_}
457	)
458	} keys %$href;
459	}
460
461
462	=head1 CPANPLUS::Selfupdate::Module
463
464	C<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects
465	by providing accessors to aid in selfupdating CPANPLUS.
466
467	These objects are returned by all methods of C<CPANPLUS::Selfupdate>
468	that return module objects.
469
470	=cut
471
472	{ package CPANPLUS::Selfupdate::Module;
473	use base 'CPANPLUS::Module';
474
475	### stores module name -> cpanplus required version
476	### XXX only can deal with 1 pair!
477	my %Cache = ();
478	my $Acc = 'version_required';
479
480	sub new {
481	my $class = shift;
482	my $mod = shift or return;
483	my $ver = shift; return unless defined $ver;
484
485	my $obj = $mod->clone; # clone the module object
486	bless $obj, $class; # rebless it to our class
487
488	$obj->$Acc( $ver );
489
490	return $obj;
491	}
492
493	=head2 $version = $mod->version_required
494
495	Returns the version of this module required for CPANPLUS.
496
497	=cut
498
499	sub version_required {
500	my $self = shift;
501	$Cache{ $self->name } = shift() if @_;
502	return $Cache{ $self->name };
503	}
504
505	=head2 $bool = $mod->is_installed_version_sufficient
506
507	Returns true if the installed version of this module is sufficient
508	for CPANPLUS, or false if it is not.
509
510	=cut
511
512
513	sub is_installed_version_sufficient {
514	my $self = shift;
515	return $self->is_uptodate( version => $self->$Acc );
516	}
517
518	}
519
520	1;
521
522	=pod
523
524	=head1 BUG REPORTS
525
526	Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
527
528	=head1 AUTHOR
529
530	This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
531
532	=head1 COPYRIGHT
533
534	The CPAN++ interface (of which this module is a part of) is copyright (c)
535	2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
536
537	This library is free software; you may redistribute and/or modify it
538	under the same terms as Perl itself.
539
540	=cut
541
542	# Local variables:
543	# c-indentation-style: bsd
544	# c-basic-offset: 4
545	# indent-tabs-mode: nil
546	# End:
547	# vim: expandtab shiftwidth=4: