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