[perl5.git] / lib / CPANPLUS / Dist.pm

package CPANPLUS::Dist;

use strict;

use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;

use Cwd ();
use Object::Accessor;
use Parse::CPAN::Meta;

use IPC::Cmd                    qw[run];
use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load check_install];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

use base 'Object::Accessor';

local $Params::Check::VERBOSE = 1;

=pod

=head1 NAME

CPANPLUS::Dist

=head1 SYNOPSIS

    my $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new(
                                module  => $modobj,
                            );

=head1 DESCRIPTION

C<CPANPLUS::Dist> is a base class for C<CPANPLUS::Dist::MM>
and C<CPANPLUS::Dist::Build>. Developers of other C<CPANPLUS::Dist::*>
plugins should look at C<CPANPLUS::Dist::Base>.

=head1 ACCESSORS

=over 4

=item parent()

Returns the C<CPANPLUS::Module> object that parented this object.

=item status()

Returns the C<Object::Accessor> object that keeps the status for
this module.

=back

=head1 STATUS ACCESSORS

All accessors can be accessed as follows:
    $deb->status->ACCESSOR

=over 4

=item created()

Boolean indicating whether the dist was created successfully.
Explicitly set to C<0> when failed, so a value of C<undef> may be
interpreted as C<not yet attempted>.

=item installed()

Boolean indicating whether the dist was installed successfully.
Explicitly set to C<0> when failed, so a value of C<undef> may be
interpreted as C<not yet attempted>.

=item uninstalled()

Boolean indicating whether the dist was uninstalled successfully.
Explicitly set to C<0> when failed, so a value of C<undef> may be
interpreted as C<not yet attempted>.

=item dist()

The location of the final distribution. This may be a file or
directory, depending on how your distribution plug in of choice
works. This will be set upon a successful create.

=cut

=back

=head2 $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( module => MODOBJ );

Create a new C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object based on the 
provided C<MODOBJ>.

*** DEPRECATED ***
The optional argument C<format> is used to indicate what type of dist
you would like to create (like C<CPANPLUS::Dist::MM> or 
C<CPANPLUS::Dist::Build> and so on ).

C<< CPANPLUS::Dist->new >> is exlusively meant as a method to be
inherited by C<CPANPLUS::Dist::MM|Build>.

Returns a C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object on success 
and false on failure.

=cut

sub new {
    my $self    = shift;
    my $class   = ref $self || $self;
    my %hash    = @_;

    ### first verify we got a module object ###
    my( $mod, $format );
    my $tmpl = {
        module  => { required => 1, allow => IS_MODOBJ, store => \$mod },
        ### for backwards compatibility
        format  => { default  => $class, store => \$format, 
                     allow    => [ __PACKAGE__->dist_types ],
        },
    };
    check( $tmpl, \%hash ) or return;

    unless( can_load( modules => { $format => '0.0' }, verbose => 1 ) ) {
        error(loc("'%1' not found -- you need '%2' version '%3' or higher ".
                    "to detect plugins", $format, 'Module::Pluggable','2.4'));
        return;
    }

    ### get an empty o::a object for this class
    my $obj = $format->SUPER::new;

    $obj->mk_accessors( qw[parent status] );
    
    ### set the parent
    $obj->parent( $mod );

    ### create a status object ###
    {   my $acc = Object::Accessor->new;
        $obj->status($acc);

        ### add minimum supported accessors
        $acc->mk_accessors( qw[prepared created installed uninstalled 
                               distdir dist] );
    }

    ### get the conf object ###
    my $conf = $mod->parent->configure_object();

    ### check if the format is available in this environment ###
    if( $conf->_get_build('sanity_check') and not $obj->format_available ) {
        error( loc( "Format '%1' is not available", $format) );
        return;
    }

    ### now initialize it or admit failure
    unless( $obj->init ) {
        error(loc("Dist initialization of '%1' failed for '%2'",
                    $format, $mod->module));
        return;
    }

    ### return the object
    return $obj;
}

=head2 @dists = CPANPLUS::Dist->dist_types;

Returns a list of the CPANPLUS::Dist::* classes available

=cut

### returns a list of dist_types we support
### will get overridden by Module::Pluggable if loaded
### XXX add support for 'plugin' dir in config as well
{   my $Loaded;
    my @Dists   = (INSTALLER_MM);
    my @Ignore  = ();

    ### backdoor method to add more dist types
    sub _add_dist_types     { my $self = shift; push @Dists,  @_ };
    
    ### backdoor method to exclude dist types
    sub _ignore_dist_types  { my $self = shift; push @Ignore, @_ };
    sub _reset_dist_ignore  { @Ignore = () };

    ### locally add the plugins dir to @INC, so we can find extra plugins
    #local @INC = @INC, File::Spec->catdir(
    #                        $conf->get_conf('base'),
    #                        $conf->_get_build('plugins') );

    ### load any possible plugins
    sub dist_types {

        if ( !$Loaded++ and check_install(  module  => 'Module::Pluggable',
                                            version => '2.4')
        ) {
            require Module::Pluggable;

            my $only_re = __PACKAGE__ . '::\w+$';
            my %except  = map { $_ => 1 }
                              INSTALLER_SAMPLE,
                              INSTALLER_BASE;

            Module::Pluggable->import(
                            sub_name    => '_dist_types',
                            search_path => __PACKAGE__,
                            only        => qr/$only_re/,
                            require     => 1,
                            except      => [ keys %except ]
                        );
            my %ignore = map { $_ => $_ } @Ignore;                        
                        
            push @Dists, grep { not $ignore{$_} and not $except{$_} }
                __PACKAGE__->_dist_types;
        }

        return @Dists;
    }

=head2 $bool = CPANPLUS::Dist->rescan_dist_types;

Rescans C<@INC> for available dist types. Useful if you've installed new
C<CPANPLUS::Dist::*> classes and want to make them available to the
current process.

=cut
    
    sub rescan_dist_types {
        my $dist    = shift;
        $Loaded     = 0;    # reset the flag;
        return $dist->dist_types;
    }        
}

=head2 $bool = CPANPLUS::Dist->has_dist_type( $type )

Returns true if distribution type C<$type> is loaded/supported.

=cut

sub has_dist_type {
    my $dist = shift;
    my $type = shift or return;
    
    return scalar grep { $_ eq $type } CPANPLUS::Dist->dist_types;
}    

=head2 $bool = $dist->prereq_satisfied( modobj => $modobj, version => $version_spec )

Returns true if this prereq is satisfied.  Returns false if it's not.
Also issues an error if it seems "unsatisfiable," i.e. if it can't be
found on CPAN or the latest CPAN version doesn't satisfy it.

=cut

sub prereq_satisfied {
    my $dist = shift;
    my $cb   = $dist->parent->parent;
    my %hash = @_;
  
    my($mod,$ver);
    my $tmpl = {
        version => { required => 1, store => \$ver },
        modobj  => { required => 1, store => \$mod, allow => IS_MODOBJ },
    };
    
    check( $tmpl, \%hash ) or return;
  
    return 1 if $mod->is_uptodate( version => $ver );
  
    if ( $cb->_vcmp( $ver, $mod->version ) > 0 ) {

        error(loc(  
                "This distribution depends on %1, but the latest version".
                " of %2 on CPAN (%3) doesn't satisfy the specific version".
                " dependency (%4). You may have to resolve this dependency ".
                "manually.", 
                $mod->module, $mod->module, $mod->version, $ver ));
  
    }

    return;
}

=head2 $configure_requires = $dist->find_configure_requires( [file => /path/to/META.yml] )

Reads the configure_requires for this distribution from the META.yml
file in the root directory and returns a hashref with module names
and versions required.

=cut

sub find_configure_requires {
    my $self = shift;
    my $mod  = $self->parent;
    my %hash = @_;
    
    my $meta;
    my $tmpl = {                ### check if we have an extract path. if not, we 
                                ### get 'undef value' warnings from file::spec
        file    => { default => do { defined $mod->status->extract
                                        ? META_YML->( $mod->status->extract )
                                        : '' },
                     store   => \$meta,
                },
    };                
    
    check( $tmpl, \%hash ) or return;
    
    ### default is an empty hashref
    my $configure_requires = $mod->status->configure_requires || {};
    
    ### if there's a meta file, we read it;
    if( -e $meta ) {

        ### Parse::CPAN::Meta uses exceptions for errors
        ### hash returned in list context!!!
        my ($doc) = eval { Parse::CPAN::Meta::LoadFile( $meta ) };
  
        unless( $doc ) {
            error(loc( "Could not read %1: '%2'", $meta, $@ ));
            return $configure_requires; # Causes problems if we don't return a hashref
        }

        ### read the configure_requires key, make sure not to throw
        ### away anything that was already added
        $configure_requires = {
            %$configure_requires,
            %{ $doc->{'configure_requires'} },
        } if $doc->{'configure_requires'};
    }
    
    ### and store it in the module
    $mod->status->configure_requires( $configure_requires );
    
    ### and return a copy
    return \%{$configure_requires};
}

=head2 $bool = $dist->_resolve_prereqs( ... )

Makes sure prerequisites are resolved

    format          The dist class to use to make the prereqs
                    (ie. CPANPLUS::Dist::MM)

    prereqs         Hash of the prerequisite modules and their versions

    target          What to do with the prereqs.
                        create  => Just build them
                        install => Install them
                        ignore  => Ignore them

    prereq_build    If true, always build the prereqs even if already
                    resolved

    verbose         Be verbose

    force           Force the prereq to be built, even if already resolved

=cut

sub _resolve_prereqs {
    my $dist = shift;
    my $self = $dist->parent;
    my $cb   = $self->parent;
    my $conf = $cb->configure_object;
    my %hash = @_;

    my ($prereqs, $format, $verbose, $target, $force, $prereq_build);
    my $tmpl = {
        ### XXX perhaps this should not be required, since it may not be
        ### packaged, just installed...
        ### Let it be empty as well -- that means the $modobj->install
        ### routine will figure it out, which is fine if we didn't have any
        ### very specific wishes (it will even detect the favourite
        ### dist_type).
        format          => { required => 1, store => \$format,
                                allow => ['',__PACKAGE__->dist_types], },
        prereqs         => { required => 1, default => { },
                                strict_type => 1, store => \$prereqs },
        verbose         => { default => $conf->get_conf('verbose'),
                                store => \$verbose },
        force           => { default => $conf->get_conf('force'),
                                store => \$force },
                        ### make sure allow matches with $mod->install's list
        target          => { default => '', store => \$target,
                                allow => ['',qw[create ignore install]] },
        prereq_build    => { default => 0, store => \$prereq_build },
    };

    check( $tmpl, \%hash ) or return;

    ### so there are no prereqs? then don't even bother
    return 1 unless keys %$prereqs;

    ### Make sure we wound up where we started.
    my $original_wd = Cwd::cwd;

    ### so you didn't provide an explicit target.
    ### maybe your config can tell us what to do.
    $target ||= {
        PREREQ_ASK,     TARGET_INSTALL, # we'll bail out if the user says no
        PREREQ_BUILD,   TARGET_CREATE,
        PREREQ_IGNORE,  TARGET_IGNORE,
        PREREQ_INSTALL, TARGET_INSTALL,
    }->{ $conf->get_conf('prereqs') } || '';
    
    ### XXX BIG NASTY HACK XXX FIXME at some point.
    ### when installing Bundle::CPANPLUS::Dependencies, we want to
    ### install all packages matching 'cpanplus' to be installed last,
    ### as all CPANPLUS' prereqs are being installed as well, but are
    ### being loaded for bootstrapping purposes. This means CPANPLUS
    ### can find them, but for example cpanplus::dist::build won't,
    ### which gets messy FAST. So, here we sort our prereqs only IF
    ### the parent module is Bundle::CPANPLUS::Dependencies.
    ### Really, we would wnat some sort of sorted prereq mechanism,
    ### but Bundle:: doesn't support it, and we flatten everything
    ### to a hash internally. A sorted hash *might* do the trick if
    ### we got a transparent implementation.. that would mean we would
    ### just have to remove the 'sort' here, and all will be well
    my @sorted_prereqs;
    
    ### use regex, could either be a module name, or a package name
    if( $self->module =~ /^Bundle(::|-)CPANPLUS(::|-)Dependencies/ ) {
        my (@first, @last);
        for my $mod ( sort keys %$prereqs ) {
            $mod =~ /CPANPLUS/
                ? push @last,  $mod
                : push @first, $mod;
        }
        @sorted_prereqs = (@first, @last);
    } else {
        @sorted_prereqs = sort keys %$prereqs;
    }

    ### first, transfer this key/value pairing into a
    ### list of module objects + desired versions
    my @install_me;
    
    for my $mod ( @sorted_prereqs ) {
        my $version = $prereqs->{$mod};
        
        ### 'perl' is a special case, there's no mod object for it
        if( $mod eq PERL_CORE ) {
            
            ### run a CLI invocation to see if the perl you specified is
            ### uptodate
            my $ok = run( command => "$^X -M$version -e1", verbose => 0 );

            unless( $ok ) {
                error(loc(  "Module '%1' needs perl version '%2', but you ".
                            "only have version '%3' -- can not proceed",
                            $self->module, $version, 
                            $cb->_perl_version( perl => $^X ) ) );
                return;                            
            }

            next;
        }
        
        my $modobj  = $cb->module_tree($mod);

        #### XXX we ignore the version, and just assume that the latest
        #### version from cpan will meet your requirements... dodgy =/
        unless( $modobj ) {
            error( loc( "No such module '%1' found on CPAN", $mod ) );
            next;
        }

        ### it's not uptodate, we need to install it
        if( !$dist->prereq_satisfied(modobj => $modobj, version => $version)) {
            msg(loc("Module '%1' requires '%2' version '%3' to be installed ",
                    $self->module, $modobj->module, $version), $verbose );

            push @install_me, [$modobj, $version];

        ### it's not an MM or Build format, that means it's a package
        ### manager... we'll need to install it as well, via the PM
        } elsif ( INSTALL_VIA_PACKAGE_MANAGER->($format) and
                    !$modobj->package_is_perl_core and
                    ($target ne TARGET_IGNORE)
        ) {
            msg(loc("Module '%1' depends on '%2', may need to build a '%3' ".
                    "package for it as well", $self->module, $modobj->module,
                    $format));
            push @install_me, [$modobj, $version];
        }
    }


    ### so you just want to ignore prereqs? ###
    if( $target eq TARGET_IGNORE ) {

        ### but you have modules you need to install
        if( @install_me ) {
            msg(loc("Ignoring prereqs, this may mean your install will fail"),
                $verbose);
            msg(loc("'%1' listed the following dependencies:", $self->module),
                $verbose);

            for my $aref (@install_me) {
                my ($mod,$version) = @$aref;

                my $str = sprintf "\t%-35s %8s\n", $mod->module, $version;
                msg($str,$verbose);
            }

            return;

        ### ok, no problem, you have all needed prereqs anyway
        } else {
            return 1;
        }
    }

    my $flag;
    for my $aref (@install_me) {
        my($modobj,$version) = @$aref;

        ### another prereq may have already installed this one...
        ### so dont ask again if the module turns out to be uptodate
        ### see bug [#11840]
        ### if either force or prereq_build are given, the prereq
        ### should be built anyway
        next if (!$force and !$prereq_build) && 
                $dist->prereq_satisfied(modobj => $modobj, version => $version);

        ### either we're told to ignore the prereq,
        ### or the user wants us to ask him
        if( ( $conf->get_conf('prereqs') == PREREQ_ASK and not
              $cb->_callbacks->install_prerequisite->($self, $modobj)
            )
        ) {
            msg(loc("Will not install prerequisite '%1' -- Note " .
                    "that the overall install may fail due to this",
                    $modobj->module), $verbose);
            next;
        }

        ### value set and false -- means failure ###
        if( defined $modobj->status->installed
            && !$modobj->status->installed
        ) {
            error( loc( "Prerequisite '%1' failed to install before in " .
                        "this session", $modobj->module ) );
            $flag++;
            last;
        }

        ### part of core?
        if( $modobj->package_is_perl_core ) {
            error(loc("Prerequisite '%1' is perl-core (%2) -- not ".
                      "installing that. Aborting install",
                      $modobj->module, $modobj->package ) );
            $flag++;
            last;
        }

        ### circular dependency code ###
        my $pending = $cb->_status->pending_prereqs || {};

        ### recursive dependency ###
        if ( $pending->{ $modobj->module } ) {
            error( loc( "Recursive dependency detected (%1) -- skipping",
                        $modobj->module ) );
            next;
        }

        ### register this dependency as pending ###
        $pending->{ $modobj->module } = $modobj;
        $cb->_status->pending_prereqs( $pending );

        ### call $modobj->install rather than doing
        ### CPANPLUS::Dist->new and the like ourselves,
        ### since ->install will take care of fetch &&
        ### extract as well
        my $pa = $dist->status->_prepare_args   || {};
        my $ca = $dist->status->_create_args    || {};
        my $ia = $dist->status->_install_args   || {};

        unless( $modobj->install(   %$pa, %$ca, %$ia,
                                    force   => $force,
                                    verbose => $verbose,
                                    format  => $format,
                                    target  => $target )
        ) {
            error(loc("Failed to install '%1' as prerequisite " .
                      "for '%2'", $modobj->module, $self->module ) );
            $flag++;
        }

        ### unregister the pending dependency ###
        $pending->{ $modobj->module } = 0;
        $cb->_status->pending_prereqs( $pending );

        last if $flag;

        ### don't want us to install? ###
        if( $target ne TARGET_INSTALL ) {
            my $dir = $modobj->status->extract
                        or error(loc("No extraction dir for '%1' found ".
                                     "-- weird", $modobj->module));

            $modobj->add_to_includepath();
            
            next;
        }
    }

    ### reset the $prereqs iterator, in case we bailed out early ###
    keys %$prereqs;

    ### chdir back to where we started
    chdir $original_wd;

    return 1 unless $flag;
    return;
}

1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
Commit	Line	Data
6aaee015 RGS	1	package CPANPLUS::Dist;
	2
	3	use strict;
	4
6aaee015 RGS	5	use CPANPLUS::Error;
	6	use CPANPLUS::Internals::Constants;
	7
4443dd53 JB	8	use Cwd ();
	9	use Object::Accessor;
	10	use Parse::CPAN::Meta;
	11
	12	use IPC::Cmd qw[run];
6aaee015 RGS	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';
6aaee015	16
4443dd53	17	use base 'Object::Accessor';
6aaee015	18
4443dd53	19	local $Params::Check::VERBOSE = 1;
6aaee015 RGS	20
	21	=pod
	22
	23	=head1 NAME
	24
	25	CPANPLUS::Dist
	26
	27	=head1 SYNOPSIS
	28
4443dd53	29	my $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new(
6aaee015 RGS	30	module => $modobj,
	31	);
	32
	33	=head1 DESCRIPTION
	34
8d5f6fc7 JB	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>.
6aaee015 RGS	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
622d31ac JB	87	=back
622d31ac JB	88
4443dd53	89	=head2 $dist = CPANPLUS::Dist::YOUR_DIST_TYPE_HERE->new( module => MODOBJ );
6aaee015	90
4443dd53 JB	91	Create a new C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object based on the
	92	provided C<MODOBJ>.
	93
	94	* DEPRECATED *
6aaee015	95	The optional argument C<format> is used to indicate what type of dist
4443dd53 JB	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>.
6aaee015	101
4443dd53 JB	102	Returns a C<CPANPLUS::Dist::YOUR_DIST_TYPE_HERE> object on success
4443dd53 JB	103	and false on failure.
6aaee015 RGS	104
	105	=cut
	106
	107	sub new {
4443dd53 JB	108	my $self = shift;
	109	my $class = ref $self \|\| $self;
	110	my %hash = @_;
6aaee015 RGS	111
6aaee015 RGS	112	### first verify we got a module object ###
4443dd53	113	my( $mod, $format );
6aaee015 RGS	114	my $tmpl = {
6aaee015 RGS	115	module => { required => 1, allow => IS_MODOBJ, store => \$mod },
4443dd53 JB	116	### for backwards compatibility
	117	format => { default => $class, store => \$format,
	118	allow => [ __PACKAGE__->dist_types ],
	119	},
6aaee015 RGS	120	};
	121	check( $tmpl, \%hash ) or return;
	122
6aaee015 RGS	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
4443dd53 JB	129	### get an empty o::a object for this class
4443dd53 JB	130	my $obj = $format->SUPER::new;
6aaee015	131
4443dd53 JB	132	$obj->mk_accessors( qw[parent status] );
	133
	134	### set the parent
	135	$obj->parent( $mod );
6aaee015 RGS	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
4443dd53 JB	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
6aaee015 RGS	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, @_ };
4443dd53	184	sub _reset_dist_ignore { @Ignore = () };
6aaee015 RGS	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+$';
4443dd53 JB	200	my %except = map { $_ => 1 }
	201	INSTALLER_SAMPLE,
	202	INSTALLER_BASE;
6aaee015 RGS	203
	204	Module::Pluggable->import(
	205	sub_name => '_dist_types',
	206	search_path => __PACKAGE__,
	207	only => qr/$only_re/,
4443dd53 JB	208	require => 1,
4443dd53 JB	209	except => [ keys %except ]
6aaee015 RGS	210	);
	211	my %ignore = map { $_ => $_ } @Ignore;
	212
4443dd53 JB	213	push @Dists, grep { not $ignore{$_} and not $except{$_} }
4443dd53 JB	214	__PACKAGE__->_dist_types;
6aaee015 RGS	215	}
	216
	217	return @Dists;
	218	}
4443dd53 JB	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	}
6aaee015 RGS	233	}
6aaee015 RGS	234
4443dd53 JB	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 )
6aaee015 RGS	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
4443dd53 JB	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, $@ ));
a0995fd4	322	return $configure_requires; # Causes problems if we don't return a hashref
4443dd53 JB	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( ... )
6aaee015 RGS	341
	342	Makes sure prerequisites are resolved
	343
4443dd53 JB	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
6aaee015 RGS	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
4443dd53 JB	397	### Make sure we wound up where we started.
	398	my $original_wd = Cwd::cwd;
	399
6aaee015 RGS	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};
4443dd53 JB	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
6aaee015 RGS	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
6aaee015 RGS	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
4443dd53 JB	615	### chdir back to where we started
	616	chdir $original_wd;
	617
6aaee015 RGS	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: