ext/CPANPLUS/lib/CPANPLUS/Dist.pm

   1 package CPANPLUS::Dist;
   2
   3 use strict;
   4
   5 use CPANPLUS::Error;
   6 use CPANPLUS::Internals::Constants;
   7
   8 use Cwd ();
   9 use Object::Accessor;
  10 use Parse::CPAN::Meta;
  11
  12 use IPC::Cmd                    qw[run];
  13 use Params::Check               qw[check];
  14 use Module::Load::Conditional   qw[can_load check_install];
  15 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  16
  17 use base 'Object::Accessor';
  18
  19 local $Params::Check::VERBOSE = 1;
  20
  21 =pod
  22
  23 =head1 NAME
  24
  25 CPANPLUS::Dist
  26
  27 =head1 SYNOPSIS
  28
  29     my $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new(
  30                                 module  => $modobj,
  31                             );
  32
  33 =head1 DESCRIPTION
  34
  35 C<CPANPLUS::Dist> is a base class for C<CPANPLUS::Dist::MM>
  36 and C<CPANPLUS::Dist::Build>. Developers of other C<CPANPLUS::Dist::*>
  37 plugins should look at C<CPANPLUS::Dist::Base>.
  38
  39 =head1 ACCESSORS
  40
  41 =over 4
  42
  43 =item parent()
  44
  45 Returns the C<CPANPLUS::Module> object that parented this object.
  46
  47 =item status()
  48
  49 Returns the C<Object::Accessor> object that keeps the status for
  50 this module.
  51
  52 =back
  53
  54 =head1 STATUS ACCESSORS
  55
  56 All accessors can be accessed as follows:
  57     $deb->status->ACCESSOR
  58
  59 =over 4
  60
  61 =item created()
  62
  63 Boolean indicating whether the dist was created successfully.
  64 Explicitly set to C<0> when failed, so a value of C<undef> may be
  65 interpreted as C<not yet attempted>.
  66
  67 =item installed()
  68
  69 Boolean indicating whether the dist was installed 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 uninstalled()
  74
  75 Boolean indicating whether the dist was uninstalled 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 dist()
  80
  81 The location of the final distribution. This may be a file or
  82 directory, depending on how your distribution plug in of choice
  83 works. This will be set upon a successful create.
  84
  85 =cut
  86
  87 =back
  88
  89 =head2 $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( module => MODOBJ );
  90
  91 Create a new C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object based on the
  92 provided C<MODOBJ>.
  93
  94 *** DEPRECATED ***
  95 The optional argument C<format> is used to indicate what type of dist
  96 you would like to create (like C<CPANPLUS::Dist::MM> or
  97 C<CPANPLUS::Dist::Build> and so on ).
  98
  99 C<< CPANPLUS::Dist->new >> is exlusively meant as a method to be
 100 inherited by C<CPANPLUS::Dist::MM|Build>.
 101
 102 Returns a C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object on success
 103 and false on failure.
 104
 105 =cut
 106
 107 sub new {
 108     my $self    = shift;
 109     my $class   = ref $self || $self;
 110     my %hash    = @_;
 111
 112     ### first verify we got a module object ###
 113     my( $mod, $format );
 114     my $tmpl = {
 115         module  => { required => 1, allow => IS_MODOBJ, store => \$mod },
 116         ### for backwards compatibility
 117         format  => { default  => $class, store => \$format,
 118                      allow    => [ __PACKAGE__->dist_types ],
 119         },
 120     };
 121     check( $tmpl, \%hash ) or return;
 122
 123     unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) {
 124         error(loc("'%1' not found -- you need '%2' version '%3' or higher ".
 125                     "to detect plugins", $format, 'Module::Pluggable','2.4'));
 126         return;
 127     }
 128
 129     ### get an empty o::a object for this class
 130     my $obj = $format->SUPER::new;
 131
 132     $obj->mk_accessors( qw[parent status] );
 133
 134     ### set the parent
 135     $obj->parent( $mod );
 136
 137     ### create a status object ###
 138     {   my $acc = Object::Accessor->new;
 139         $obj->status($acc);
 140
 141         ### add minimum supported accessors
 142         $acc->mk_accessors( qw[prepared created installed uninstalled
 143                                distdir dist] );
 144     }
 145
 146     ### get the conf object ###
 147     my $conf = $mod->parent->configure_object();
 148
 149     ### check if the format is available in this environment ###
 150     if( $conf->_get_build('sanity_check') and not $obj->format_available ) {
 151         error( loc( "Format '%1' is not available", $format) );
 152         return;
 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     sub _reset_dist_ignore  { @Ignore = () };
 185
 186     ### locally add the plugins dir to @INC, so we can find extra plugins
 187     #local @INC = @INC, File::Spec->catdir(
 188     #                        $conf->get_conf('base'),
 189     #                        $conf->_get_build('plugins') );
 190
 191     ### load any possible plugins
 192     sub dist_types {
 193
 194         if ( !$Loaded++ and check_install(  module  => 'Module::Pluggable',
 195                                             version => '2.4')
 196         ) {
 197             require Module::Pluggable;
 198
 199             my $only_re = __PACKAGE__ . '::\w+$';
 200             my %except  = map { $_ => 1 }
 201                               INSTALLER_SAMPLE,
 202                               INSTALLER_BASE;
 203
 204             Module::Pluggable->import(
 205                             sub_name    => '_dist_types',
 206                             search_path => __PACKAGE__,
 207                             only        => qr/$only_re/,
 208                             require     => 1,
 209                             except      => [ keys %except ]
 210                         );
 211             my %ignore = map { $_ => $_ } @Ignore;
 212
 213             push @Dists, grep { not $ignore{$_} and not $except{$_} }
 214                 __PACKAGE__->_dist_types;
 215         }
 216
 217         return @Dists;
 218     }
 219
 220 =head2 $bool = CPANPLUS::Dist->rescan_dist_types;
 221
 222 Rescans C<@INC> for available dist types. Useful if you've installed new
 223 C<CPANPLUS::Dist::*> classes and want to make them available to the
 224 current process.
 225
 226 =cut
 227
 228     sub rescan_dist_types {
 229         my $dist    = shift;
 230         $Loaded     = 0;    # reset the flag;
 231         return $dist->dist_types;
 232     }
 233 }
 234
 235 =head2 $bool = CPANPLUS::Dist->has_dist_type( $type )
 236
 237 Returns true if distribution type C<$type> is loaded/supported.
 238
 239 =cut
 240
 241 sub has_dist_type {
 242     my $dist = shift;
 243     my $type = shift or return;
 244
 245     return scalar grep { $_ eq $type } CPANPLUS::Dist->dist_types;
 246 }
 247
 248 =head2 $bool = $dist->prereq_satisfied( modobj => $modobj, version => $version_spec )
 249
 250 Returns true if this prereq is satisfied.  Returns false if it's not.
 251 Also issues an error if it seems "unsatisfiable," i.e. if it can't be
 252 found on CPAN or the latest CPAN version doesn't satisfy it.
 253
 254 =cut
 255
 256 sub prereq_satisfied {
 257     my $dist = shift;
 258     my $cb   = $dist->parent->parent;
 259     my %hash = @_;
 260
 261     my($mod,$ver);
 262     my $tmpl = {
 263         version => { required => 1, store => \$ver },
 264         modobj  => { required => 1, store => \$mod, allow => IS_MODOBJ },
 265     };
 266
 267     check( $tmpl, \%hash ) or return;
 268
 269     return 1 if $mod->is_uptodate( version => $ver );
 270
 271     if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) {
 272
 273         error(loc(
 274                 "This distribution depends on %1, but the latest version".
 275                 " of %2 on CPAN (%3) doesn't satisfy the specific version".
 276                 " dependency (%4). You may have to resolve this dependency ".
 277                 "manually.",
 278                 $mod->module, $mod->module, $mod->version, $ver ));
 279
 280     }
 281
 282     return;
 283 }
 284
 285 =head2 $configure_requires = $dist->find_configure_requires( [file => /path/to/META.yml] )
 286
 287 Reads the configure_requires for this distribution from the META.yml
 288 file in the root directory and returns a hashref with module names
 289 and versions required.
 290
 291 =cut
 292
 293 sub find_configure_requires {
 294     my $self = shift;
 295     my $mod  = $self->parent;
 296     my %hash = @_;
 297
 298     my $meta;
 299     my $tmpl = {                ### check if we have an extract path. if not, we
 300                                 ### get 'undef value' warnings from file::spec
 301         file    => { default => do { defined $mod->status->extract
 302                                         ? META_YML->( $mod->status->extract )
 303                                         : '' },
 304                      store   => \$meta,
 305                 },
 306     };
 307
 308     check( $tmpl, \%hash ) or return;
 309
 310     ### default is an empty hashref
 311     my $configure_requires = $mod->status->configure_requires || {};
 312
 313     ### if there's a meta file, we read it;
 314     if( -e $meta ) {
 315
 316         ### Parse::CPAN::Meta uses exceptions for errors
 317         ### hash returned in list context!!!
 318         my ($doc) = eval { Parse::CPAN::Meta::LoadFile( $meta ) };
 319
 320         unless( $doc ) {
 321             error(loc( "Could not read %1: '%2'", $meta, $@ ));
 322             return $configure_requires; # Causes problems if we don't return a hashref
 323         }
 324
 325         ### read the configure_requires key, make sure not to throw
 326         ### away anything that was already added
 327         $configure_requires = {
 328             %$configure_requires,
 329             %{ $doc->{'configure_requires'} },
 330         } if $doc->{'configure_requires'};
 331     }
 332
 333     ### and store it in the module
 334     $mod->status->configure_requires( $configure_requires );
 335
 336     ### and return a copy
 337     return \%{$configure_requires};
 338 }
 339
 340 =head2 $bool = $dist->_resolve_prereqs( ... )
 341
 342 Makes sure prerequisites are resolved
 343
 344     format          The dist class to use to make the prereqs
 345                     (ie. CPANPLUS::Dist::MM)
 346
 347     prereqs         Hash of the prerequisite modules and their versions
 348
 349     target          What to do with the prereqs.
 350                         create  => Just build them
 351                         install => Install them
 352                         ignore  => Ignore them
 353
 354     prereq_build    If true, always build the prereqs even if already
 355                     resolved
 356
 357     verbose         Be verbose
 358
 359     force           Force the prereq to be built, even if already resolved
 360
 361 =cut
 362
 363 sub _resolve_prereqs {
 364     my $dist = shift;
 365     my $self = $dist->parent;
 366     my $cb   = $self->parent;
 367     my $conf = $cb->configure_object;
 368     my %hash = @_;
 369
 370     my ($prereqs, $format, $verbose, $target, $force, $prereq_build);
 371     my $tmpl = {
 372         ### XXX perhaps this should not be required, since it may not be
 373         ### packaged, just installed...
 374         ### Let it be empty as well -- that means the $modobj->install
 375         ### routine will figure it out, which is fine if we didn't have any
 376         ### very specific wishes (it will even detect the favourite
 377         ### dist_type).
 378         format          => { required => 1, store => \$format,
 379                                 allow => ['',__PACKAGE__->dist_types], },
 380         prereqs         => { required => 1, default => { },
 381                                 strict_type => 1, store => \$prereqs },
 382         verbose         => { default => $conf->get_conf('verbose'),
 383                                 store => \$verbose },
 384         force           => { default => $conf->get_conf('force'),
 385                                 store => \$force },
 386                         ### make sure allow matches with $mod->install's list
 387         target          => { default => '', store => \$target,
 388                                 allow => ['',qw[create ignore install]] },
 389         prereq_build    => { default => 0, store => \$prereq_build },
 390     };
 391
 392     check( $tmpl, \%hash ) or return;
 393
 394     ### so there are no prereqs? then don't even bother
 395     return 1 unless keys %$prereqs;
 396
 397     ### Make sure we wound up where we started.
 398     my $original_wd = Cwd::cwd;
 399
 400     ### so you didn't provide an explicit target.
 401     ### maybe your config can tell us what to do.
 402     $target ||= {
 403         PREREQ_ASK,     TARGET_INSTALL, # we'll bail out if the user says no
 404         PREREQ_BUILD,   TARGET_CREATE,
 405         PREREQ_IGNORE,  TARGET_IGNORE,
 406         PREREQ_INSTALL, TARGET_INSTALL,
 407     }->{ $conf->get_conf('prereqs') } || '';
 408
 409     ### XXX BIG NASTY HACK XXX FIXME at some point.
 410     ### when installing Bundle::CPANPLUS::Dependencies, we want to
 411     ### install all packages matching 'cpanplus' to be installed last,
 412     ### as all CPANPLUS' prereqs are being installed as well, but are
 413     ### being loaded for bootstrapping purposes. This means CPANPLUS
 414     ### can find them, but for example cpanplus::dist::build won't,
 415     ### which gets messy FAST. So, here we sort our prereqs only IF
 416     ### the parent module is Bundle::CPANPLUS::Dependencies.
 417     ### Really, we would wnat some sort of sorted prereq mechanism,
 418     ### but Bundle:: doesn't support it, and we flatten everything
 419     ### to a hash internally. A sorted hash *might* do the trick if
 420     ### we got a transparent implementation.. that would mean we would
 421     ### just have to remove the 'sort' here, and all will be well
 422     my @sorted_prereqs;
 423
 424     ### use regex, could either be a module name, or a package name
 425     if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) {
 426         my (@first, @last);
 427         for my $mod ( sort keys %$prereqs ) {
 428             $mod =~ /CPANPLUS/
 429                 ? push @last,  $mod
 430                 : push @first, $mod;
 431         }
 432         @sorted_prereqs = (@first, @last);
 433     } else {
 434         @sorted_prereqs = sort keys %$prereqs;
 435     }
 436
 437     ### first, transfer this key/value pairing into a
 438     ### list of module objects + desired versions
 439     my @install_me;
 440
 441     for my $mod ( @sorted_prereqs ) {
 442         my $version = $prereqs->{$mod};
 443
 444         ### 'perl' is a special case, there's no mod object for it
 445         if( $mod eq PERL_CORE ) {
 446
 447             ### run a CLI invocation to see if the perl you specified is
 448             ### uptodate
 449             my $ok = run( command => "$^X -M$version -e1", verbose => 0 );
 450
 451             unless( $ok ) {
 452                 error(loc(  "Module '%1' needs perl version '%2', but you ".
 453                             "only have version '%3' -- can not proceed",
 454                             $self->module, $version,
 455                             $cb->_perl_version( perl => $^X ) ) );
 456                 return;
 457             }
 458
 459             next;
 460         }
 461
 462         my $modobj  = $cb->module_tree($mod);
 463
 464         #### XXX we ignore the version, and just assume that the latest
 465         #### version from cpan will meet your requirements... dodgy =/
 466         unless( $modobj ) {
 467             error( loc( "No such module '%1' found on CPAN", $mod ) );
 468             next;
 469         }
 470
 471         ### it's not uptodate, we need to install it
 472         if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) {
 473             msg(loc("Module '%1' requires '%2' version '%3' to be installed ",
 474                     $self->module, $modobj->module, $version), $verbose );
 475
 476             push @install_me, [$modobj, $version];
 477
 478         ### it's not an MM or Build format, that means it's a package
 479         ### manager... we'll need to install it as well, via the PM
 480         } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and
 481                     !$modobj->package_is_perl_core and
 482                     ($target ne TARGET_IGNORE)
 483         ) {
 484             msg(loc("Module '%1' depends on '%2', may need to build a '%3' ".
 485                     "package for it as well", $self->module, $modobj->module,
 486                     $format));
 487             push @install_me, [$modobj, $version];
 488         }
 489     }
 490
 491
 492
 493     ### so you just want to ignore prereqs? ###
 494     if( $target eq TARGET_IGNORE ) {
 495
 496         ### but you have modules you need to install
 497         if( @install_me ) {
 498             msg(loc("Ignoring prereqs, this may mean your install will fail"),
 499                 $verbose);
 500             msg(loc("'%1' listed the following dependencies:", $self->module),
 501                 $verbose);
 502
 503             for my $aref (@install_me) {
 504                 my ($mod,$version) = @$aref;
 505
 506                 my $str = sprintf "\t%-35s %8s\n", $mod->module, $version;
 507                 msg($str,$verbose);
 508             }
 509
 510             return;
 511
 512         ### ok, no problem, you have all needed prereqs anyway
 513         } else {
 514             return 1;
 515         }
 516     }
 517
 518     my $flag;
 519     for my $aref (@install_me) {
 520         my($modobj,$version) = @$aref;
 521
 522         ### another prereq may have already installed this one...
 523         ### so dont ask again if the module turns out to be uptodate
 524         ### see bug [#11840]
 525         ### if either force or prereq_build are given, the prereq
 526         ### should be built anyway
 527         next if (!$force and !$prereq_build) &&
 528                 $dist->prereq_satisfied(modobj => $modobj, version => $version);
 529
 530         ### either we're told to ignore the prereq,
 531         ### or the user wants us to ask him
 532         if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not
 533               $cb->_callbacks->install_prerequisite->($self, $modobj)
 534             )
 535         ) {
 536             msg(loc("Will not install prerequisite '%1' -- Note " .
 537                     "that the overall install may fail due to this",
 538                     $modobj->module), $verbose);
 539             next;
 540         }
 541
 542         ### value set and false -- means failure ###
 543         if( defined $modobj->status->installed
 544             && !$modobj->status->installed
 545         ) {
 546             error( loc( "Prerequisite '%1' failed to install before in " .
 547                         "this session", $modobj->module ) );
 548             $flag++;
 549             last;
 550         }
 551
 552         ### part of core?
 553         if( $modobj->package_is_perl_core ) {
 554             error(loc("Prerequisite '%1' is perl-core (%2) -- not ".
 555                       "installing that. Aborting install",
 556                       $modobj->module, $modobj->package ) );
 557             $flag++;
 558             last;
 559         }
 560
 561         ### circular dependency code ###
 562         my $pending = $cb->_status->pending_prereqs || {};
 563
 564         ### recursive dependency ###
 565         if ( $pending->{ $modobj->module } ) {
 566             error( loc( "Recursive dependency detected (%1) -- skipping",
 567                         $modobj->module ) );
 568             next;
 569         }
 570
 571         ### register this dependency as pending ###
 572         $pending->{ $modobj->module } = $modobj;
 573         $cb->_status->pending_prereqs( $pending );
 574
 575         ### call $modobj->install rather than doing
 576         ### CPANPLUS::Dist->new and the like ourselves,
 577         ### since ->install will take care of fetch &&
 578         ### extract as well
 579         my $pa = $dist->status->_prepare_args   || {};
 580         my $ca = $dist->status->_create_args    || {};
 581         my $ia = $dist->status->_install_args   || {};
 582
 583         unless( $modobj->install(   %$pa, %$ca, %$ia,
 584                                     force   => $force,
 585                                     verbose => $verbose,
 586                                     format  => $format,
 587                                     target  => $target )
 588         ) {
 589             error(loc("Failed to install '%1' as prerequisite " .
 590                       "for '%2'", $modobj->module, $self->module ) );
 591             $flag++;
 592         }
 593
 594         ### unregister the pending dependency ###
 595         $pending->{ $modobj->module } = 0;
 596         $cb->_status->pending_prereqs( $pending );
 597
 598         last if $flag;
 599
 600         ### don't want us to install? ###
 601         if( $target ne TARGET_INSTALL ) {
 602             my $dir = $modobj->status->extract
 603                         or error(loc("No extraction dir for '%1' found ".
 604                                      "-- weird", $modobj->module));
 605
 606             $modobj->add_to_includepath();
 607
 608             next;
 609         }
 610     }
 611
 612     ### reset the $prereqs iterator, in case we bailed out early ###
 613     keys %$prereqs;
 614
 615     ### chdir back to where we started
 616     chdir $original_wd;
 617
 618     return 1 unless $flag;
 619     return;
 620 }
 621
 622 1;
 623
 624 # Local variables:
 625 # c-indentation-style: bsd
 626 # c-basic-offset: 4
 627 # indent-tabs-mode: nil
 628 # End:
 629 # vim: expandtab shiftwidth=4: