[Summary view] [Print] [Text view]

   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: