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