lib/CPANPLUS/Selfupdate.pm

   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 => {
  43             'File::Fetch'               => '0.08', # win32 ftp support
  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',
  49             'Module::Load::Conditional' => '0.16', # Better parsing: #23995
  50             'version'                   => '0.70', # needed for M::L::C
  51                                                    # addresses #24630 and
  52                                                    # #24675
  53             'Params::Check'             => '0.22',
  54             'Package::Constants'        => '0.01',
  55             'Term::UI'                  => '0.05',
  56             'Test::Harness'             => '2.62', # due to bug #19505
  57                                                    # only 2.58 and 2.60 are bad
  58             'Test::More'                => '0.47', # to run our tests
  59             'Archive::Extract'          => '0.16', # ./Dir bug fix
  60             'Archive::Tar'              => '1.23',
  61             'IO::Zlib'                  => '1.04', # needed for Archive::Tar
  62             'Object::Accessor'          => '0.32', # overloaded stringification
  63             'Module::CoreList'          => '2.09',
  64             'Module::Pluggable'         => '2.4',
  65             'Module::Loaded'            => '0.01',
  66         },
  67
  68         features => {
  69             # config_key_name => [
  70             #     sub { } to list module key/value pairs
  71             #     sub { } to check if feature is enabled
  72             # ]
  73             prefer_makefile => [
  74                 sub {
  75                     my $cb = shift;
  76                     $cb->configure_object->get_conf('prefer_makefile')
  77                         ? { }
  78                         : { 'CPANPLUS::Dist::Build' => '0.04'  };
  79                 },
  80                 sub { return 1 },   # always enabled
  81             ],
  82             cpantest        => [
  83                 {
  84                     LWP              => '0.0',
  85                     'LWP::UserAgent' => '0.0',
  86                     'HTTP::Request'  => '0.0',
  87                     URI              => '0.0',
  88                     YAML             => '0.0',
  89                     'Test::Reporter' => 1.27,
  90                 },
  91                 sub {
  92                     my $cb = shift;
  93                     return $cb->configure_object->get_conf('cpantest');
  94                 },
  95             ],
  96             dist_type => [
  97                 sub {
  98                     my $cb      = shift;
  99                     my $dist    = $cb->configure_object->get_conf('dist_type');
 100                     return { $dist => '0.0' } if $dist;
 101                     return;
 102                 },
 103                 sub {
 104                     my $cb = shift;
 105                     return $cb->configure_object->get_conf('dist_type');
 106                 },
 107             ],
 108
 109             md5 => [
 110                 {
 111                     'Digest::MD5'   => '0.0',
 112                 },
 113                 sub {
 114                     my $cb = shift;
 115                     return $cb->configure_object->get_conf('md5');
 116                 },
 117             ],
 118             shell => [
 119                 sub {
 120                     my $cb      = shift;
 121                     my $dist    = $cb->configure_object->get_conf('shell');
 122
 123                     ### we bundle these shells, so don't bother having a dep
 124                     ### on them... If we don't do this, CPAN.pm actually detects
 125                     ### a recursive dependency and breaks (see #26077).
 126                     ### This is not an issue for CPANPLUS itself, it handles
 127                     ### it smartly.
 128                     return if $dist eq SHELL_DEFAULT or $dist eq SHELL_CLASSIC;
 129                     return { $dist => '0.0' } if $dist;
 130                     return;
 131                 },
 132                 sub { return 1 },
 133             ],
 134             signature => [
 135                 sub {
 136                     my $cb      = shift;
 137                     return if can_run('gpg');
 138                         ### leave this out -- Crypt::OpenPGP is fairly
 139                         ### painful to install, and broken on some platforms
 140                         ### so we'll just always fall back to gpg. It may
 141                         ### issue a warning or 2, but that's about it.
 142                         ### this change due to this ticket: #26914
 143                         # and $cb->configure_object->get_conf('prefer_bin');
 144                     return { 'Crypt::OpenPGP' => '0.0' };
 145                 },
 146                 sub {
 147                     my $cb = shift;
 148                     return $cb->configure_object->get_conf('signature');
 149                 },
 150             ],
 151             storable => [
 152                 { 'Storable' => '0.0' },
 153                 sub {
 154                     my $cb = shift;
 155                     return $cb->configure_object->get_conf('storable');
 156                 },
 157             ],
 158         },
 159         core => {
 160             'CPANPLUS' => '0.0',
 161         },
 162     };
 163
 164     sub _get_config { return $Modules }
 165 }
 166
 167 =head1 METHODS
 168
 169 =head2 $self = CPANPLUS::Selfupdate->new( $backend_object );
 170
 171 Sets up a new selfupdate object. Called automatically when
 172 a new backend object is created.
 173
 174 =cut
 175
 176 sub new {
 177     my $class = shift;
 178     my $cb    = shift or return;
 179     return bless sub { $cb }, $class;
 180 }
 181
 182
 183
 184 =head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", latest => BOOL )
 185
 186 Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself),
 187 the core dependencies, all features you have currently turned on, or
 188 all features available, or everything.
 189
 190 The C<latest> option determines whether it should update to the latest
 191 version on CPAN, or if the minimal required version for CPANPLUS is
 192 good enough.
 193
 194 Returns true on success, false on error.
 195
 196 =cut
 197
 198 sub selfupdate {
 199     my $self = shift;
 200     my $cb   = $self->();
 201     my $conf = $cb->configure_object;
 202     my %hash = @_;
 203
 204     ### cache to find the relevant modules
 205     my $cache = {
 206         core                => sub { $self->list_core_modules               },
 207         dependencies        => sub { $self->list_core_dependencies          },
 208         enabled_features    => sub { map { $self->modules_for_feature( $_ ) }
 209                                         $self->list_enabled_features
 210                                 },
 211         features            => sub { map { $self->modules_for_feature( $_ ) }
 212                                      $self->list_features
 213                                 },
 214                                 ### make sure to do 'core' first, in case
 215                                 ### we are out of date ourselves
 216         all                 => [ qw|core dependencies enabled_features| ],
 217     };
 218
 219     my($type, $latest, $force);
 220     my $tmpl = {
 221         update  => { required => 1, store => \$type,
 222                      allow    => [ keys %$cache ],  },
 223         latest  => { default  => 0, store => \$latest,    allow => BOOLEANS },
 224         force   => { default => $conf->get_conf('force'), store => \$force },
 225     };
 226
 227     check( $tmpl, \%hash ) or return;
 228
 229     my $ref     = $cache->{$type};
 230     my @mods    = UNIVERSAL::isa( $ref, 'ARRAY' )
 231                     ? map { $cache->{$_}->() } @$ref
 232                     : $ref->();
 233
 234     ### do we need the latest versions?
 235     @mods       = $latest
 236                     ? @mods
 237                     : grep { !$_->is_installed_version_sufficient } @mods;
 238
 239     my $flag;
 240     for my $mod ( @mods ) {
 241         unless( $mod->install( force => $force ) ) {
 242             $flag++;
 243             error(loc("Failed to update module '%1'", $mod->name));
 244         }
 245     }
 246
 247     return if $flag;
 248     return 1;
 249 }
 250
 251 =head2 @features = $self->list_features
 252
 253 Returns a list of features that are supported by CPANPLUS.
 254
 255 =cut
 256
 257 sub list_features {
 258     my $self = shift;
 259     return keys %{ $self->_get_config->{'features'} };
 260 }
 261
 262 =head2 @features = $self->list_enabled_features
 263
 264 Returns a list of features that are enabled in your current
 265 CPANPLUS installation.
 266
 267 =cut
 268
 269 sub list_enabled_features {
 270     my $self = shift;
 271     my $cb   = $self->();
 272
 273     my @enabled;
 274     for my $feat ( $self->list_features ) {
 275         my $ref = $self->_get_config->{'features'}->{$feat}->[1];
 276         push @enabled, $feat if $ref->($cb);
 277     }
 278
 279     return @enabled;
 280 }
 281
 282 =head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] )
 283
 284 Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
 285 represent the modules required to support this feature.
 286
 287 For a list of features, call the C<list_features> method.
 288
 289 If the C<AS_HASH> argument is provided, no module objects are
 290 returned, but a hashref where the keys are names of the modules,
 291 and values are their minimum versions.
 292
 293 =cut
 294
 295 sub modules_for_feature {
 296     my $self    = shift;
 297     my $feature = shift or return;
 298     my $as_hash = shift || 0;
 299     my $cb      = $self->();
 300
 301     unless( exists $self->_get_config->{'features'}->{$feature} ) {
 302         error(loc("Unknown feature '%1'", $feature));
 303         return;
 304     }
 305
 306     my $ref = $self->_get_config->{'features'}->{$feature}->[0];
 307
 308     ### it's either a list of modules/versions or a subroutine that
 309     ### returns a list of modules/versions
 310     my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb );
 311
 312     return unless $href;    # nothing needed for the feature?
 313
 314     return $href if $as_hash;
 315     return $self->_hashref_to_module( $href );
 316 }
 317
 318
 319 =head2 @mods = $self->list_core_dependencies( [AS_HASH] )
 320
 321 Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
 322 represent the modules that comprise the core dependencies of CPANPLUS.
 323
 324 If the C<AS_HASH> argument is provided, no module objects are
 325 returned, but a hashref where the keys are names of the modules,
 326 and values are their minimum versions.
 327
 328 =cut
 329
 330 sub list_core_dependencies {
 331     my $self    = shift;
 332     my $as_hash = shift || 0;
 333     my $cb      = $self->();
 334     my $href    = $self->_get_config->{'dependencies'};
 335
 336     return $href if $as_hash;
 337     return $self->_hashref_to_module( $href );
 338 }
 339
 340 =head2 @mods = $self->list_core_modules( [AS_HASH] )
 341
 342 Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
 343 represent the modules that comprise the core of CPANPLUS.
 344
 345 If the C<AS_HASH> argument is provided, no module objects are
 346 returned, but a hashref where the keys are names of the modules,
 347 and values are their minimum versions.
 348
 349 =cut
 350
 351 sub list_core_modules {
 352     my $self    = shift;
 353     my $as_hash = shift || 0;
 354     my $cb      = $self->();
 355     my $href    = $self->_get_config->{'core'};
 356
 357     return $href if $as_hash;
 358     return $self->_hashref_to_module( $href );
 359 }
 360
 361 sub _hashref_to_module {
 362     my $self = shift;
 363     my $cb   = $self->();
 364     my $href = shift or return;
 365
 366     return map {
 367             CPANPLUS::Selfupdate::Module->new(
 368                 $cb->module_tree($_) => $href->{$_}
 369             )
 370         } keys %$href;
 371 }
 372
 373
 374 =head1 CPANPLUS::Selfupdate::Module
 375
 376 C<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects
 377 by providing accessors to aid in selfupdating CPANPLUS.
 378
 379 These objects are returned by all methods of C<CPANPLUS::Selfupdate>
 380 that return module objects.
 381
 382 =cut
 383
 384 {   package CPANPLUS::Selfupdate::Module;
 385     use base 'CPANPLUS::Module';
 386
 387     ### stores module name -> cpanplus required version
 388     ### XXX only can deal with 1 pair!
 389     my %Cache = ();
 390     my $Acc   = 'version_required';
 391
 392     sub new {
 393         my $class = shift;
 394         my $mod   = shift or return;
 395         my $ver   = shift;          return unless defined $ver;
 396
 397         my $obj   = $mod->clone;    # clone the module object
 398         bless $obj, $class;         # rebless it to our class
 399
 400         $obj->$Acc( $ver );
 401
 402         return $obj;
 403     }
 404
 405 =head2 $version = $mod->version_required
 406
 407 Returns the version of this module required for CPANPLUS.
 408
 409 =cut
 410
 411     sub version_required {
 412         my $self = shift;
 413         $Cache{ $self->name } = shift() if @_;
 414         return $Cache{ $self->name };
 415     }
 416
 417 =head2 $bool = $mod->is_installed_version_sufficient
 418
 419 Returns true if the installed version of this module is sufficient
 420 for CPANPLUS, or false if it is not.
 421
 422 =cut
 423
 424
 425     sub is_installed_version_sufficient {
 426         my $self = shift;
 427         return $self->is_uptodate( version => $self->$Acc );
 428     }
 429
 430 }
 431
 432 1;
 433
 434 =pod
 435
 436 =head1 BUG REPORTS
 437
 438 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
 439
 440 =head1 AUTHOR
 441
 442 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
 443
 444 =head1 COPYRIGHT
 445
 446 The CPAN++ interface (of which this module is a part of) is copyright (c)
 447 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
 448
 449 This library is free software; you may redistribute and/or modify it
 450 under the same terms as Perl itself.
 451
 452 =cut
 453
 454 # Local variables:
 455 # c-indentation-style: bsd
 456 # c-basic-offset: 4
 457 # indent-tabs-mode: nil
 458 # End:
 459 # vim: expandtab shiftwidth=4: