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