summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm547
1 files changed, 547 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm
new file mode 100644
index 00000000000..48f918ce82e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Selfupdate.pm
@@ -0,0 +1,547 @@
+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.31_01', # 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.22', # deprecated core modules
+ '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',
+ 'Parse::CPAN::Meta' => '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: