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') and
 138                         $cb->configure_object->get_conf('prefer_bin');
 139                     return { 'Crypt::OpenPGP' => '0.0' };
 140                 },
 141                 sub {
 142                     my $cb = shift;
 143                     return $cb->configure_object->get_conf('signature');
 144                 },
 145             ],
 146             storable => [
 147                 { 'Storable' => '0.0' },
 148                 sub {
 149                     my $cb = shift;
 150                     return $cb->configure_object->get_conf('storable');
 151                 },
 152             ],
 153         },
 154         core => {
 155             'CPANPLUS' => '0.0',
 156         },
 157     };
 158
 159     sub _get_config { return $Modules }
 160 }
 161
 162 =head1 METHODS
 163
 164 =head2 $self = CPANPLUS::Selfupdate->new( $backend_object );
 165
 166 Sets up a new selfupdate object. Called automatically when
 167 a new backend object is created.
 168
 169 =cut
 170
 171 sub new {
 172     my $class = shift;
 173     my $cb    = shift or return;
 174     return bless sub { $cb }, $class;
 175 }
 176
 177
 178
 179 =head2 $bool = $self->selfupdate( update => "core|dependencies|enabled_features|features|all", latest => BOOL )
 180
 181 Selfupdate CPANPLUS. You can update either the core (CPANPLUS itself),
 182 the core dependencies, all features you have currently turned on, or
 183 all features available, or everything.
 184
 185 The C<latest> option determines whether it should update to the latest
 186 version on CPAN, or if the minimal required version for CPANPLUS is
 187 good enough.
 188
 189 Returns true on success, false on error.
 190
 191 =cut
 192
 193 sub selfupdate {
 194     my $self = shift;
 195     my $cb   = $self->();
 196     my $conf = $cb->configure_object;
 197     my %hash = @_;
 198
 199     ### cache to find the relevant modules
 200     my $cache = {
 201         core                => sub { $self->list_core_modules               },
 202         dependencies        => sub { $self->list_core_dependencies          },
 203         enabled_features    => sub { map { $self->modules_for_feature( $_ ) }
 204                                         $self->list_enabled_features
 205                                 },
 206         features            => sub { 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     my($type, $latest, $force);
 215     my $tmpl = {
 216         update  => { required => 1, store => \$type,
 217                      allow    => [ keys %$cache ],  },
 218         latest  => { default  => 0, store => \$latest,    allow => BOOLEANS },
 219         force   => { default => $conf->get_conf('force'), store => \$force },
 220     };
 221
 222     check( $tmpl, \%hash ) or return;
 223
 224     my $ref     = $cache->{$type};
 225     my @mods    = UNIVERSAL::isa( $ref, 'ARRAY' )
 226                     ? map { $cache->{$_}->() } @$ref
 227                     : $ref->();
 228
 229     ### do we need the latest versions?
 230     @mods       = $latest
 231                     ? @mods
 232                     : grep { $_->is_installed_version_sufficient } @mods;
 233
 234     my $flag;
 235     for my $mod ( @mods ) {
 236         unless( $mod->install( force => $force ) ) {
 237             $flag++;
 238             error(loc("Failed to update module '%1'", $mod->name));
 239         }
 240     }
 241
 242     return if $flag;
 243     return 1;
 244 }
 245
 246 =head2 @features = $self->list_features
 247
 248 Returns a list of features that are supported by CPANPLUS.
 249
 250 =cut
 251
 252 sub list_features {
 253     my $self = shift;
 254     return keys %{ $self->_get_config->{'features'} };
 255 }
 256
 257 =head2 @features = $self->list_enabled_features
 258
 259 Returns a list of features that are enabled in your current
 260 CPANPLUS installation.
 261
 262 =cut
 263
 264 sub list_enabled_features {
 265     my $self = shift;
 266     my $cb   = $self->();
 267
 268     my @enabled;
 269     for my $feat ( $self->list_features ) {
 270         my $ref = $self->_get_config->{'features'}->{$feat}->[1];
 271         push @enabled, $feat if $ref->($cb);
 272     }
 273
 274     return @enabled;
 275 }
 276
 277 =head2 @mods = $self->modules_for_feature( FEATURE [,AS_HASH] )
 278
 279 Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
 280 represent the modules required to support this feature.
 281
 282 For a list of features, call the C<list_features> method.
 283
 284 If the C<AS_HASH> argument is provided, no module objects are
 285 returned, but a hashref where the keys are names of the modules,
 286 and values are their minimum versions.
 287
 288 =cut
 289
 290 sub modules_for_feature {
 291     my $self    = shift;
 292     my $feature = shift or return;
 293     my $as_hash = shift || 0;
 294     my $cb      = $self->();
 295
 296     unless( exists $self->_get_config->{'features'}->{$feature} ) {
 297         error(loc("Unknown feature '%1'", $feature));
 298         return;
 299     }
 300
 301     my $ref = $self->_get_config->{'features'}->{$feature}->[0];
 302
 303     ### it's either a list of modules/versions or a subroutine that
 304     ### returns a list of modules/versions
 305     my $href = UNIVERSAL::isa( $ref, 'HASH' ) ? $ref : $ref->( $cb );
 306
 307     return unless $href;    # nothing needed for the feature?
 308
 309     return $href if $as_hash;
 310     return $self->_hashref_to_module( $href );
 311 }
 312
 313
 314 =head2 @mods = $self->list_core_dependencies( [AS_HASH] )
 315
 316 Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
 317 represent the modules that comprise the core dependencies of CPANPLUS.
 318
 319 If the C<AS_HASH> argument is provided, no module objects are
 320 returned, but a hashref where the keys are names of the modules,
 321 and values are their minimum versions.
 322
 323 =cut
 324
 325 sub list_core_dependencies {
 326     my $self    = shift;
 327     my $as_hash = shift || 0;
 328     my $cb      = $self->();
 329     my $href    = $self->_get_config->{'dependencies'};
 330
 331     return $href if $as_hash;
 332     return $self->_hashref_to_module( $href );
 333 }
 334
 335 =head2 @mods = $self->list_core_modules( [AS_HASH] )
 336
 337 Returns a list of C<CPANPLUS::Selfupdate::Module> objects which
 338 represent the modules that comprise the core of CPANPLUS.
 339
 340 If the C<AS_HASH> argument is provided, no module objects are
 341 returned, but a hashref where the keys are names of the modules,
 342 and values are their minimum versions.
 343
 344 =cut
 345
 346 sub list_core_modules {
 347     my $self    = shift;
 348     my $as_hash = shift || 0;
 349     my $cb      = $self->();
 350     my $href    = $self->_get_config->{'core'};
 351
 352     return $href if $as_hash;
 353     return $self->_hashref_to_module( $href );
 354 }
 355
 356 sub _hashref_to_module {
 357     my $self = shift;
 358     my $cb   = $self->();
 359     my $href = shift or return;
 360
 361     return map {
 362             CPANPLUS::Selfupdate::Module->new(
 363                 $cb->module_tree($_) => $href->{$_}
 364             )
 365         } keys %$href;
 366 }
 367
 368
 369 =head1 CPANPLUS::Selfupdate::Module
 370
 371 C<CPANPLUS::Selfupdate::Module> extends C<CPANPLUS::Module> objects
 372 by providing accessors to aid in selfupdating CPANPLUS.
 373
 374 These objects are returned by all methods of C<CPANPLUS::Selfupdate>
 375 that return module objects.
 376
 377 =cut
 378
 379 {   package CPANPLUS::Selfupdate::Module;
 380     use base 'CPANPLUS::Module';
 381
 382     ### stores module name -> cpanplus required version
 383     ### XXX only can deal with 1 pair!
 384     my %Cache = ();
 385     my $Acc   = 'version_required';
 386
 387     sub new {
 388         my $class = shift;
 389         my $mod   = shift or return;
 390         my $ver   = shift;          return unless defined $ver;
 391
 392         my $obj   = $mod->clone;    # clone the module object
 393         bless $obj, $class;         # rebless it to our class
 394
 395         $obj->$Acc( $ver );
 396
 397         return $obj;
 398     }
 399
 400 =head2 $version = $mod->version_required
 401
 402 Returns the version of this module required for CPANPLUS.
 403
 404 =cut
 405
 406     sub version_required {
 407         my $self = shift;
 408         $Cache{ $self->name } = shift() if @_;
 409         return $Cache{ $self->name };
 410     }
 411
 412 =head2 $bool = $mod->is_installed_version_sufficient
 413
 414 Returns true if the installed version of this module is sufficient
 415 for CPANPLUS, or false if it is not.
 416
 417 =cut
 418
 419
 420     sub is_installed_version_sufficient {
 421         my $self = shift;
 422         return $self->is_uptodate( version => $self->$Acc );
 423     }
 424
 425 }
 426
 427 1;
 428
 429 =pod
 430
 431 =head1 BUG REPORTS
 432
 433 Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
 434
 435 =head1 AUTHOR
 436
 437 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
 438
 439 =head1 COPYRIGHT
 440
 441 The CPAN++ interface (of which this module is a part of) is copyright (c)
 442 2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
 443
 444 This library is free software; you may redistribute and/or modify it
 445 under the same terms as Perl itself.
 446
 447 =cut
 448
 449 # Local variables:
 450 # c-indentation-style: bsd
 451 # c-basic-offset: 4
 452 # indent-tabs-mode: nil
 453 # End:
 454 # vim: expandtab shiftwidth=4: