[Summary view] [Print] [Text view]

   1  package CPANPLUS::Dist;
   2  
   3  use strict;
   4  
   5  
   6  use CPANPLUS::Error;
   7  use CPANPLUS::Internals::Constants;
   8  
   9  use Params::Check               qw[check];
  10  use Module::Load::Conditional   qw[can_load check_install];
  11  use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  12  use Object::Accessor;
  13  
  14  local $Params::Check::VERBOSE = 1;
  15  
  16  my @methods = qw[status parent];
  17  for my $key ( @methods ) {
  18      no strict 'refs';
  19      *{__PACKAGE__."::$key"} = sub {
  20          my $self = shift;
  21          $self->{$key} = $_[0] if @_;
  22          return $self->{$key};
  23      }
  24  }
  25  
  26  =pod
  27  
  28  =head1 NAME
  29  
  30  CPANPLUS::Dist
  31  
  32  =head1 SYNOPSIS
  33  
  34      my $dist = CPANPLUS::Dist->new(
  35                                  format  => 'build',
  36                                  module  => $modobj,
  37                              );
  38  
  39  =head1 DESCRIPTION
  40  
  41  C<CPANPLUS::Dist> is a base class for C<CPANPLUS::Dist::MM>
  42  and C<CPANPLUS::Dist::Build>. Developers of other C<CPANPLUS::Dist::*>
  43  plugins should look at C<CPANPLUS::Dist::Base>.
  44  
  45  =head1 ACCESSORS
  46  
  47  =over 4
  48  
  49  =item parent()
  50  
  51  Returns the C<CPANPLUS::Module> object that parented this object.
  52  
  53  =item status()
  54  
  55  Returns the C<Object::Accessor> object that keeps the status for
  56  this module.
  57  
  58  =back
  59  
  60  =head1 STATUS ACCESSORS
  61  
  62  All accessors can be accessed as follows:
  63      $deb->status->ACCESSOR
  64  
  65  =over 4
  66  
  67  =item created()
  68  
  69  Boolean indicating whether the dist was created successfully.
  70  Explicitly set to C<0> when failed, so a value of C<undef> may be
  71  interpreted as C<not yet attempted>.
  72  
  73  =item installed()
  74  
  75  Boolean indicating whether the dist was installed successfully.
  76  Explicitly set to C<0> when failed, so a value of C<undef> may be
  77  interpreted as C<not yet attempted>.
  78  
  79  =item uninstalled()
  80  
  81  Boolean indicating whether the dist was uninstalled successfully.
  82  Explicitly set to C<0> when failed, so a value of C<undef> may be
  83  interpreted as C<not yet attempted>.
  84  
  85  =item dist()
  86  
  87  The location of the final distribution. This may be a file or
  88  directory, depending on how your distribution plug in of choice
  89  works. This will be set upon a successful create.
  90  
  91  =cut
  92  
  93  =back
  94  
  95  =head2 $dist = CPANPLUS::Dist->new( module => MODOBJ, [format => DIST_TYPE] );
  96  
  97  Create a new C<CPANPLUS::Dist> object based on the provided C<MODOBJ>.
  98  The optional argument C<format> is used to indicate what type of dist
  99  you would like to create (like C<makemaker> for a C<CPANPLUS::Dist::MM>
 100  object, C<build> for a C<CPANPLUS::Dist::Build> object, and so on ).
 101  If not provided, will default to the setting as specified by your
 102  config C<dist_type>.
 103  
 104  Returns a C<CPANPLUS::Dist> object on success and false on failure.
 105  
 106  =cut
 107  
 108  sub new {
 109      my $self = shift;
 110      my %hash = @_;
 111  
 112      local $Params::Check::ALLOW_UNKNOWN = 1;
 113  
 114      ### first verify we got a module object ###
 115      my $mod;
 116      my $tmpl = {
 117          module  => { required => 1, allow => IS_MODOBJ, store => \$mod },
 118      };
 119      check( $tmpl, \%hash ) or return;
 120  
 121      ### get the conf object ###
 122      my $conf = $mod->parent->configure_object();
 123  
 124      ### figure out what type of dist object to create ###
 125      my $format;
 126      my $tmpl2 = {
 127          format  => {    default => $conf->get_conf('dist_type'),
 128                          allow   => [ __PACKAGE__->dist_types ],
 129                          store   => \$format  },
 130      };
 131      check( $tmpl2, \%hash ) or return;
 132  
 133  
 134      unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) {
 135          error(loc("'%1' not found -- you need '%2' version '%3' or higher ".
 136                      "to detect plugins", $format, 'Module::Pluggable','2.4'));
 137          return;
 138      }
 139  
 140      ### bless the object in the child class ###
 141      my $obj = bless { parent => $mod }, $format;
 142  
 143      ### check if the format is available in this environment ###
 144      if( $conf->_get_build('sanity_check') and not $obj->format_available ) {
 145          error( loc( "Format '%1' is not available",$format) );
 146          return;
 147      }
 148  
 149      ### create a status object ###
 150      {   my $acc = Object::Accessor->new;
 151          $obj->status($acc);
 152  
 153          ### add minimum supported accessors
 154          $acc->mk_accessors( qw[prepared created installed uninstalled 
 155                                 distdir dist] );
 156      }
 157  
 158      ### now initialize it or admit failure
 159      unless( $obj->init ) {
 160          error(loc("Dist initialization of '%1' failed for '%2'",
 161                      $format, $mod->module));
 162          return;
 163      }
 164  
 165      ### return the object
 166      return $obj;
 167  }
 168  
 169  =head2 @dists = CPANPLUS::Dist->dist_types;
 170  
 171  Returns a list of the CPANPLUS::Dist::* classes available
 172  
 173  =cut
 174  
 175  ### returns a list of dist_types we support
 176  ### will get overridden by Module::Pluggable if loaded
 177  ### XXX add support for 'plugin' dir in config as well
 178  {   my $Loaded;
 179      my @Dists   = (INSTALLER_MM);
 180      my @Ignore  = ();
 181  
 182      ### backdoor method to add more dist types
 183      sub _add_dist_types     { my $self = shift; push @Dists,  @_ };
 184      
 185      ### backdoor method to exclude dist types
 186      sub _ignore_dist_types  { my $self = shift; push @Ignore, @_ };
 187  
 188      ### locally add the plugins dir to @INC, so we can find extra plugins
 189      #local @INC = @INC, File::Spec->catdir(
 190      #                        $conf->get_conf('base'),
 191      #                        $conf->_get_build('plugins') );
 192  
 193      ### load any possible plugins
 194      sub dist_types {
 195  
 196          if ( !$Loaded++ and check_install(  module  => 'Module::Pluggable',
 197                                              version => '2.4')
 198          ) {
 199              require Module::Pluggable;
 200  
 201              my $only_re = __PACKAGE__ . '::\w+$';
 202  
 203              Module::Pluggable->import(
 204                              sub_name    => '_dist_types',
 205                              search_path => __PACKAGE__,
 206                              only        => qr/$only_re/,
 207                              except      => [ INSTALLER_MM, 
 208                                               INSTALLER_SAMPLE,
 209                                               INSTALLER_BASE,
 210                                          ]
 211                          );
 212              my %ignore = map { $_ => $_ } @Ignore;                        
 213                          
 214              push @Dists, grep { not $ignore{$_}  } __PACKAGE__->_dist_types;
 215          }
 216  
 217          return @Dists;
 218      }
 219  }
 220  
 221  =head2 prereq_satisfied( modobj => $modobj, version => $version_spec )
 222  
 223  Returns true if this prereq is satisfied.  Returns false if it's not.
 224  Also issues an error if it seems "unsatisfiable," i.e. if it can't be
 225  found on CPAN or the latest CPAN version doesn't satisfy it.
 226  
 227  =cut
 228  
 229  sub prereq_satisfied {
 230      my $dist = shift;
 231      my $cb   = $dist->parent->parent;
 232      my %hash = @_;
 233    
 234      my($mod,$ver);
 235      my $tmpl = {
 236          version => { required => 1, store => \$ver },
 237          modobj  => { required => 1, store => \$mod, allow => IS_MODOBJ },
 238      };
 239      
 240      check( $tmpl, \%hash ) or return;
 241    
 242      return 1 if $mod->is_uptodate( version => $ver );
 243    
 244      if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) {
 245  
 246          error(loc(  
 247                  "This distribution depends on %1, but the latest version".
 248                  " of %2 on CPAN (%3) doesn't satisfy the specific version".
 249                  " dependency (%4). You may have to resolve this dependency ".
 250                  "manually.", 
 251                  $mod->module, $mod->module, $mod->version, $ver ));
 252    
 253      }
 254  
 255      return;
 256  }
 257  
 258  =head2 _resolve_prereqs
 259  
 260  Makes sure prerequisites are resolved
 261  
 262  XXX Need docs, internal use only
 263  
 264  =cut
 265  
 266  sub _resolve_prereqs {
 267      my $dist = shift;
 268      my $self = $dist->parent;
 269      my $cb   = $self->parent;
 270      my $conf = $cb->configure_object;
 271      my %hash = @_;
 272  
 273      my ($prereqs, $format, $verbose, $target, $force, $prereq_build);
 274      my $tmpl = {
 275          ### XXX perhaps this should not be required, since it may not be
 276          ### packaged, just installed...
 277          ### Let it be empty as well -- that means the $modobj->install
 278          ### routine will figure it out, which is fine if we didn't have any
 279          ### very specific wishes (it will even detect the favourite
 280          ### dist_type).
 281          format          => { required => 1, store => \$format,
 282                                  allow => ['',__PACKAGE__->dist_types], },
 283          prereqs         => { required => 1, default => { },
 284                                  strict_type => 1, store => \$prereqs },
 285          verbose         => { default => $conf->get_conf('verbose'),
 286                                  store => \$verbose },
 287          force           => { default => $conf->get_conf('force'),
 288                                  store => \$force },
 289                          ### make sure allow matches with $mod->install's list
 290          target          => { default => '', store => \$target,
 291                                  allow => ['',qw[create ignore install]] },
 292          prereq_build    => { default => 0, store => \$prereq_build },
 293      };
 294  
 295      check( $tmpl, \%hash ) or return;
 296  
 297      ### so there are no prereqs? then don't even bother
 298      return 1 unless keys %$prereqs;
 299  
 300      ### so you didn't provide an explicit target.
 301      ### maybe your config can tell us what to do.
 302      $target ||= {
 303          PREREQ_ASK,     TARGET_INSTALL, # we'll bail out if the user says no
 304          PREREQ_BUILD,   TARGET_CREATE,
 305          PREREQ_IGNORE,  TARGET_IGNORE,
 306          PREREQ_INSTALL, TARGET_INSTALL,
 307      }->{ $conf->get_conf('prereqs') } || '';
 308      
 309      ### XXX BIG NASTY HACK XXX FIXME at some point.
 310      ### when installing Bundle::CPANPLUS::Dependencies, we want to
 311      ### install all packages matching 'cpanplus' to be installed last,
 312      ### as all CPANPLUS' prereqs are being installed as well, but are
 313      ### being loaded for bootstrapping purposes. This means CPANPLUS
 314      ### can find them, but for example cpanplus::dist::build won't,
 315      ### which gets messy FAST. So, here we sort our prereqs only IF
 316      ### the parent module is Bundle::CPANPLUS::Dependencies.
 317      ### Really, we would wnat some sort of sorted prereq mechanism,
 318      ### but Bundle:: doesn't support it, and we flatten everything
 319      ### to a hash internally. A sorted hash *might* do the trick if
 320      ### we got a transparent implementation.. that would mean we would
 321      ### just have to remove the 'sort' here, and all will be well
 322      my @sorted_prereqs;
 323      
 324      ### use regex, could either be a module name, or a package name
 325      if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) {
 326          my (@first, @last);
 327          for my $mod ( sort keys %$prereqs ) {
 328              $mod =~ /CPANPLUS/
 329                  ? push @last,  $mod
 330                  : push @first, $mod;
 331          }
 332          @sorted_prereqs = (@first, @last);
 333      } else {
 334          @sorted_prereqs = sort keys %$prereqs;
 335      }
 336  
 337      ### first, transfer this key/value pairing into a
 338      ### list of module objects + desired versions
 339      my @install_me;
 340      
 341      for my $mod ( @sorted_prereqs ) {
 342          my $version = $prereqs->{$mod};
 343          my $modobj  = $cb->module_tree($mod);
 344  
 345          #### XXX we ignore the version, and just assume that the latest
 346          #### version from cpan will meet your requirements... dodgy =/
 347          unless( $modobj ) {
 348              error( loc( "No such module '%1' found on CPAN", $mod ) );
 349              next;
 350          }
 351  
 352          ### it's not uptodate, we need to install it
 353          if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) {
 354              msg(loc("Module '%1' requires '%2' version '%3' to be installed ",
 355                      $self->module, $modobj->module, $version), $verbose );
 356  
 357              push @install_me, [$modobj, $version];
 358  
 359          ### it's not an MM or Build format, that means it's a package
 360          ### manager... we'll need to install it as well, via the PM
 361          } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and
 362                      !$modobj->package_is_perl_core and
 363                      ($target ne TARGET_IGNORE)
 364          ) {
 365              msg(loc("Module '%1' depends on '%2', may need to build a '%3' ".
 366                      "package for it as well", $self->module, $modobj->module,
 367                      $format));
 368              push @install_me, [$modobj, $version];
 369          }
 370      }
 371  
 372  
 373  
 374      ### so you just want to ignore prereqs? ###
 375      if( $target eq TARGET_IGNORE ) {
 376  
 377          ### but you have modules you need to install
 378          if( @install_me ) {
 379              msg(loc("Ignoring prereqs, this may mean your install will fail"),
 380                  $verbose);
 381              msg(loc("'%1' listed the following dependencies:", $self->module),
 382                  $verbose);
 383  
 384              for my $aref (@install_me) {
 385                  my ($mod,$version) = @$aref;
 386  
 387                  my $str = sprintf "\t%-35s %8s\n", $mod->module, $version;
 388                  msg($str,$verbose);
 389              }
 390  
 391              return;
 392  
 393          ### ok, no problem, you have all needed prereqs anyway
 394          } else {
 395              return 1;
 396          }
 397      }
 398  
 399      my $flag;
 400      for my $aref (@install_me) {
 401          my($modobj,$version) = @$aref;
 402  
 403          ### another prereq may have already installed this one...
 404          ### so dont ask again if the module turns out to be uptodate
 405          ### see bug [#11840]
 406          ### if either force or prereq_build are given, the prereq
 407          ### should be built anyway
 408          next if (!$force and !$prereq_build) && 
 409                  $dist->prereq_satisfied(modobj => $modobj, version => $version);
 410  
 411          ### either we're told to ignore the prereq,
 412          ### or the user wants us to ask him
 413          if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not
 414                $cb->_callbacks->install_prerequisite->($self, $modobj)
 415              )
 416          ) {
 417              msg(loc("Will not install prerequisite '%1' -- Note " .
 418                      "that the overall install may fail due to this",
 419                      $modobj->module), $verbose);
 420              next;
 421          }
 422  
 423          ### value set and false -- means failure ###
 424          if( defined $modobj->status->installed
 425              && !$modobj->status->installed
 426          ) {
 427              error( loc( "Prerequisite '%1' failed to install before in " .
 428                          "this session", $modobj->module ) );
 429              $flag++;
 430              last;
 431          }
 432  
 433          ### part of core?
 434          if( $modobj->package_is_perl_core ) {
 435              error(loc("Prerequisite '%1' is perl-core (%2) -- not ".
 436                        "installing that. Aborting install",
 437                        $modobj->module, $modobj->package ) );
 438              $flag++;
 439              last;
 440          }
 441  
 442          ### circular dependency code ###
 443          my $pending = $cb->_status->pending_prereqs || {};
 444  
 445          ### recursive dependency ###
 446          if ( $pending->{ $modobj->module } ) {
 447              error( loc( "Recursive dependency detected (%1) -- skipping",
 448                          $modobj->module ) );
 449              next;
 450          }
 451  
 452          ### register this dependency as pending ###
 453          $pending->{ $modobj->module } = $modobj;
 454          $cb->_status->pending_prereqs( $pending );
 455  
 456  
 457          ### call $modobj->install rather than doing
 458          ### CPANPLUS::Dist->new and the like ourselves,
 459          ### since ->install will take care of fetch &&
 460          ### extract as well
 461          my $pa = $dist->status->_prepare_args   || {};
 462          my $ca = $dist->status->_create_args    || {};
 463          my $ia = $dist->status->_install_args   || {};
 464  
 465          unless( $modobj->install(   %$pa, %$ca, %$ia,
 466                                      force   => $force,
 467                                      verbose => $verbose,
 468                                      format  => $format,
 469                                      target  => $target )
 470          ) {
 471              error(loc("Failed to install '%1' as prerequisite " .
 472                        "for '%2'", $modobj->module, $self->module ) );
 473              $flag++;
 474          }
 475  
 476          ### unregister the pending dependency ###
 477          $pending->{ $modobj->module } = 0;
 478          $cb->_status->pending_prereqs( $pending );
 479  
 480          last if $flag;
 481  
 482          ### don't want us to install? ###
 483          if( $target ne TARGET_INSTALL ) {
 484              my $dir = $modobj->status->extract
 485                          or error(loc("No extraction dir for '%1' found ".
 486                                       "-- weird", $modobj->module));
 487  
 488              $modobj->add_to_includepath();
 489              
 490              next;
 491          }
 492      }
 493  
 494      ### reset the $prereqs iterator, in case we bailed out early ###
 495      keys %$prereqs;
 496  
 497      return 1 unless $flag;
 498      return;
 499  }
 500  
 501  1;
 502  
 503  # Local variables:
 504  # c-indentation-style: bsd
 505  # c-basic-offset: 4
 506  # indent-tabs-mode: nil
 507  # End:
 508  # vim: expandtab shiftwidth=4: