lib/CPANPLUS/Dist.pm

   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: