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