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