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.15_02', # lynx & 404 handling
  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.28', # returns dir for loaded
  50                                                    # modules
  51             'version'                   => '0.73', # needed for M::L::C
  52                                                    # addresses #24630 and
  53                                                    # #24675
  54                                                    # Address ~0 overflow issue
  55             'Params::Check'             => '0.22',
  56             'Package::Constants'        => '0.01',
  57             'Term::UI'                  => '0.18', # option parsing
  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
  64             'Object::Accessor'          => '0.34', # mk_aliases support
  65             'Module::CoreList'          => '2.09',
  66             'Module::Pluggable'         => '2.4',
  67             'Module::Loaded'            => '0.01',
  68             'Parse::CPAN::Meta'         => '0.02', # config_requires support
  69             'ExtUtils::Install'         => '1.42', # uninstall outside @INC
  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                         ? { }
  82                         : { 'CPANPLUS::Dist::Build' => '0.04'  };
  83                 },
  84                 sub { return 1 },   # always enabled
  85             ],
  86             cpantest        => [
  87                 { 'Test::Reporter'  => '1.34',
  88                   'YAML::Tiny'      => '0.0'
  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');
 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;
 128                     return { $dist => '0.0' } if $dist;
 129                     return;
 130                 },
 131                 sub { return 1 },
 132             ],
 133             signature => [
 134                 sub {
 135                     my $cb      = shift;
 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                     };
 150                 },
 151                 sub {
 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             ],
 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             ],
 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
 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};
 274
 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] )
 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
 305     sub selfupdate {
 306         my $self = shift;
 307         my $cb   = $self->();
 308         my $conf = $cb->configure_object;
 309         my %hash = @_;
 310
 311         my $force;
 312         my $tmpl = {
 313             force  => { default => $conf->get_conf('force'), store => \$force },
 314         };
 315
 316         {   local $Params::Check::ALLOW_UNKNOWN = 1;
 317             check( $tmpl, \%hash ) or return;
 318         }
 319
 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 }
 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: