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 {   ### cache to find the relevant modules
 184     my $cache = {
 185         core
 186             => sub { my $self = shift;
 187                      core => [ $self->list_core_modules ]   },
 188
 189         dependencies
 190             => sub { my $self = shift;
 191                      dependencies => [ $self->list_core_dependencies ] },
 192
 193         enabled_features
 194             => sub { my $self = shift;
 195                      map { $_ => [ $self->modules_for_feature( $_ ) ] }
 196                         $self->list_enabled_features
 197                    },
 198         features
 199             => sub { my $self = shift;
 200                      map { $_ => [ $self->modules_for_feature( $_ ) ] }
 201                         $self->list_features
 202                    },
 203             ### make sure to do 'core' first, in case
 204             ### we are out of date ourselves
 205         all => [ qw|core dependencies enabled_features| ],
 206     };
 207
 208
 209 =head2 @cat = $self->list_categories
 210
 211 Returns a list of categories that the C<selfupdate> method accepts.
 212
 213 See C<selfupdate> for details.
 214
 215 =cut
 216
 217     sub list_categories { return sort keys %$cache }
 218
 219 =head2 %list = $self->list_modules_to_update( update => "core|dependencies|enabled_features|features|all", [latest => BOOL] )
 220
 221 List which modules C<selfupdate> would upgrade. You can update either
 222 the core (CPANPLUS itself), the core dependencies, all features you have
 223 currently turned on, or all features available, or everything.
 224
 225 The C<latest> option determines whether it should update to the latest
 226 version on CPAN, or if the minimal required version for CPANPLUS is
 227 good enough.
 228
 229 Returns a hash of feature names and lists of module objects to be
 230 upgraded based on the category you provided. For example:
 231
 232     %list = $self->list_modules_to_update( update => 'core' );
 233
 234 Would return:
 235
 236     ( core => [ $module_object_for_cpanplus ] );
 237
 238 =cut
 239
 240     sub list_modules_to_update {
 241         my $self = shift;
 242         my $cb   = $self->();
 243         my $conf = $cb->configure_object;
 244         my %hash = @_;
 245
 246         my($type, $latest);
 247         my $tmpl = {
 248             update => { required => 1, store => \$type,
 249                          allow   => [ keys %$cache ], },
 250             latest => { default  => 0, store => \$latest, allow => BOOLEANS },
 251         };
 252
 253         {   local $Params::Check::ALLOW_UNKNOWN = 1;
 254             check( $tmpl, \%hash ) or return;
 255         }
 256
 257         my $ref     = $cache->{$type};
 258
 259         ### a list of ( feature1 => \@mods, feature2 => \@mods, etc )
 260         my %list    = UNIVERSAL::isa( $ref, 'ARRAY' )
 261                             ? map { $cache->{$_}->( $self ) } @$ref
 262                             : $ref->( $self );
 263
 264         ### filter based on whether we need the latest ones or not
 265         for my $aref ( values %list ) {
 266               $aref = [ $latest
 267                         ? grep { !$_->is_uptodate } @$aref
 268                         : grep { !$_->is_installed_version_sufficient } @$aref
 269                       ];
 270         }
 271
 272         return %list;
 273     }
 274
 275 =head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", [latest => BOOL, force => BOOL] )
 276
 277 Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself),
 278 the core dependencies, all features you have currently turned on, or
 279 all features available, or everything.
 280
 281 The C<latest> option determines whether it should update to the latest
 282 version on CPAN, or if the minimal required version for CPANPLUS is
 283 good enough.
 284
 285 Returns true on success, false on error.
 286
 287 =cut
 288
 289     sub selfupdate {
 290         my $self = shift;
 291         my $cb   = $self->();
 292         my $conf = $cb->configure_object;
 293         my %hash = @_;
 294
 295         my $force;
 296         my $tmpl = {
 297             force  => { default => $conf->get_conf('force'), store => \$force },
 298         };
 299
 300         {   local $Params::Check::ALLOW_UNKNOWN = 1;
 301             check( $tmpl, \%hash ) or return;
 302         }
 303
 304         my %list = $self->list_modules_to_update( %hash ) or return;
 305
 306         ### just the modules please
 307         my @mods = map { @$_ } values %list;
 308
 309         my $flag;
 310         for my $mod ( @mods ) {
 311             unless( $mod->install( force => $force ) ) {
 312                 $flag++;
 313                 error(loc("Failed to update module '%1'", $mod->name));
 314             }
 315         }
 316
 317         return if $flag;
 318         return 1;
 319     }
 320
 321 }
 322
 323 =head2 @features = $self->list_features
 324
 325 Returns a list of features that are supported by CPANPLUS.
 326
 327 =cut
 328
 329 sub list_features {
 330     my $self = shift;
 331     return keys %{ $self->_get_config->{'features'} };
 332 }
 333
 334 =head2 @features = $self->list_enabled_features
 335
 336 Returns a list of features that are enabled in your current
 337 CPANPLUS installation.
 338
 339 =cut
 340
 341 sub list_enabled_features {
 342     my $self = shift;
 343     my $cb   = $self->();
 344
 345     my @enabled;
 346     for my $feat ( $self->list_features ) {
 347         my $ref = $self->_get_config->{'features'}->{$feat}->[1];
 348         push @enabled, $feat if $ref->($cb);
 349     }
 350
 351     return @enabled;
 352 }
 353
 354 =head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] )
 355
 356 Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
 357 represent the modules required to support this feature.
 358
 359 For a list of features, call the C<list_features> method.
 360
 361 If the C<AS_HASH> argument is provided, no module objects are
 362 returned, but a hashref where the keys are names of the modules,
 363 and values are their minimum versions.
 364
 365 =cut
 366
 367 sub modules_for_feature {
 368     my $self    = shift;
 369     my $feature = shift or return;
 370     my $as_hash = shift || 0;
 371     my $cb      = $self->();
 372
 373     unless( exists $self->_get_config->{'features'}->{$feature} ) {
 374         error(loc("Unknown feature '%1'", $feature));
 375         return;
 376     }
 377
 378     my $ref = $self->_get_config->{'features'}->{$feature}->[0];
 379
 380     ### it's either a list of modules/versions or a subroutine that
 381     ### returns a list of modules/versions
 382     my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb );
 383
 384     return unless $href;    # nothing needed for the feature?
 385
 386     return $href if $as_hash;
 387     return $self->_hashref_to_module( $href );
 388 }
 389
 390
 391 =head2 @mods = $self->list_core_dependencies( [AS_HASH] )
 392
 393 Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
 394 represent the modules that comprise the core dependencies of CPANPLUS.
 395
 396 If the C<AS_HASH> argument is provided, no module objects are
 397 returned, but a hashref where the keys are names of the modules,
 398 and values are their minimum versions.
 399
 400 =cut
 401
 402 sub list_core_dependencies {
 403     my $self    = shift;
 404     my $as_hash = shift || 0;
 405     my $cb      = $self->();
 406     my $href    = $self->_get_config->{'dependencies'};
 407
 408     return $href if $as_hash;
 409     return $self->_hashref_to_module( $href );
 410 }
 411
 412 =head2 @mods = $self->list_core_modules( [AS_HASH] )
 413
 414 Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
 415 represent the modules that comprise the core of CPANPLUS.
 416
 417 If the C<AS_HASH> argument is provided, no module objects are
 418 returned, but a hashref where the keys are names of the modules,
 419 and values are their minimum versions.
 420
 421 =cut
 422
 423 sub list_core_modules {
 424     my $self    = shift;
 425     my $as_hash = shift || 0;
 426     my $cb      = $self->();
 427     my $href    = $self->_get_config->{'core'};
 428
 429     return $href if $as_hash;
 430     return $self->_hashref_to_module( $href );
 431 }
 432
 433 sub _hashref_to_module {
 434     my $self = shift;
 435     my $cb   = $self->();
 436     my $href = shift or return;
 437
 438     return map {
 439             CPANPLUS::Selfupdate::Module->new(
 440                 $cb->module_tree($_) => $href->{$_}
 441             )
 442         } keys %$href;
 443 }
 444
 445
 446 =head1 CPANPLUS::Selfupdate::Module
 447
 448 C<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects
 449 by providing accessors to aid in selfupdating CPANPLUS.
 450
 451 These objects are returned by all methods of C<CPANPLUS::Selfupdate>
 452 that return module objects.
 453
 454 =cut
 455
 456 {   package CPANPLUS::Selfupdate::Module;
 457     use base 'CPANPLUS::Module';
 458
 459     ### stores module name -> cpanplus required version
 460     ### XXX only can deal with 1 pair!
 461     my %Cache = ();
 462     my $Acc   = 'version_required';
 463
 464     sub new {
 465         my $class = shift;
 466         my $mod   = shift or return;
 467         my $ver   = shift;          return unless defined $ver;
 468
 469         my $obj   = $mod->clone;    # clone the module object
 470         bless $obj, $class;         # rebless it to our class
 471
 472         $obj->$Acc( $ver );
 473
 474         return $obj;
 475     }
 476
 477 =head2 $version = $mod->version_required
 478
 479 Returns the version of this module required for CPANPLUS.
 480
 481 =cut
 482
 483     sub version_required {
 484         my $self = shift;
 485         $Cache{ $self->name } = shift() if @_;
 486         return $Cache{ $self->name };
 487     }
 488
 489 =head2 $bool = $mod->is_installed_version_sufficient
 490
 491 Returns true if the installed version of this module is sufficient
 492 for CPANPLUS, or false if it is not.
 493
 494 =cut
 495
 496
 497     sub is_installed_version_sufficient {
 498         my $self = shift;
 499         return $self->is_uptodate( version => $self->$Acc );
 500     }
 501
 502 }
 503
 504 1;
 505
 506 =pod
 507
 508 =head1 BUG REPORTS
 509
 510 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
 511
 512 =head1 AUTHOR
 513
 514 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
 515
 516 =head1 COPYRIGHT
 517
 518 The CPAN++ interface (of which this module is a part of) is copyright (c)
 519 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
 520
 521 This library is free software; you may redistribute and/or modify it
 522 under the same terms as Perl itself.
 523
 524 =cut
 525
 526 # Local variables:
 527 # c-indentation-style: bsd
 528 # c-basic-offset: 4
 529 # indent-tabs-mode: nil
 530 # End:
 531 # vim: expandtab shiftwidth=4: