File Coverage

lib/CPANPLUS/Dist.pm

Criterion	Covered	Total	%
statement	262	291	90.0
branch	75	110	68.1
condition	33	49	67.3
subroutine	26	26	100.0
pod	6	7	85.7
total	402	483	83.2

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 vars qw[$VERSION];
$VERSION = "0.9912";

use base 'Object::Accessor';

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

=pod

=head1 NAME

CPANPLUS::Dist - base class for plugins

=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 exclusively 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 _metadata] );
    }

    ### 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 or META.json
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 $href = {};

    my $tmpl = {
        file => { store => \$meta },
    };

    $self->_stash_metadata(); # Okay hacks.

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

    my $meth = 'configure_requires';

    {

      ### the prereqs as we have them now
      my @args = (
        defaults => $mod->status->$meth || {},
      );

      my @possibles = do { defined $mod->status->extract
                           ? ( META_JSON->( $mod->status->extract ),
                               META_YML->( $mod->status->extract ) )
                           : ()
                      };

      unshift @possibles, $meta if $meta;

      META: foreach my $mfile ( grep { -e } @possibles ) {
          push @args, ( file => $mfile );
          if ( $mfile =~ /\.json/ ) {
            $href = $self->_prereqs_from_meta_json( @args, keys => [ 'configure' ] );
          }
          else {
            $href = $self->_prereqs_from_meta_file( @args, keys => [ $meth ] );
          }
          last META;
      }

    }

    ### and store it in the module
    $mod->status->$meth( $href );

    return { %$href };
}

sub find_mymeta_requires {
    my $self = shift;
    my $mod  = $self->parent;
    my %hash = @_;

    my ($meta);
    my $href = {};

    my $tmpl = {
        file => { store => \$meta },
    };

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

    my $meth = 'prereqs';

    {

      ### the prereqs as we have them now
      my @args = (
        defaults => $mod->status->$meth || {},
      );

      my @possibles = do { defined $mod->status->extract
                           ? ( MYMETA_JSON->( $mod->status->extract ),
                               MYMETA_YML->( $mod->status->extract ) )
                           : ()
                      };

      unshift @possibles, $meta if $meta;

      META: foreach my $mfile ( grep { -e } @possibles ) {
          push @args, ( file => $mfile );
          if ( $mfile =~ /\.json/ ) {
            $href = $self->_prereqs_from_meta_json( @args,
                keys => [ qw|build test runtime| ] );
          }
          else {
            $href = $self->_prereqs_from_meta_file( @args,
                keys => [ qw|build_requires requires| ] );
          }
          last META;
      }

    }

    ### and store it in the module
    $mod->status->$meth( $href );

    return { %$href };
}

sub _prereqs_from_meta_file {
    my $self = shift;
    my $mod  = $self->parent;
    my %hash = @_;

    my( $meta, $defaults, $keys );
    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,
                    },
        defaults    => { required => 1, default => {}, strict_type => 1,
                         store => \$defaults },
        keys        => { required => 1, default => [], strict_type => 1,
                         store => \$keys },
    };

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

    ### if there's a meta file, we read it;
    if( -e $meta ) {

        ### Parse::CPAN::Meta uses exceptions for errors
        ### hash returned in list context!!!

        local $ENV{PERL_YAML_BACKEND};

        my ($doc) = eval { Parse::CPAN::Meta::LoadFile( $meta ) };

        unless( $doc ) {
            error(loc( "Could not read %1: '%2'", $meta, $@ ));
            return $defaults;
        }

        ### read the keys now, make sure not to throw
        ### away anything that was already added
        for my $key ( @$keys ) {
            $defaults = {
                %$defaults,
                %{ $doc->{$key} },
            } if $doc->{ $key };
        }
    }

    ### and return a copy
    return \%{ $defaults };
}

sub _prereqs_from_meta_json {
    my $self = shift;
    my $mod  = $self->parent;
    my %hash = @_;

    my( $meta, $defaults, $keys );
    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_JSON->( $mod->status->extract )
                                        : '' },
                        store   => \$meta,
                    },
        defaults    => { required => 1, default => {}, strict_type => 1,
                         store => \$defaults },
        keys        => { required => 1, default => [], strict_type => 1,
                         store => \$keys },
    };

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

    ### if there's a meta file, we read it;
    if( -e $meta ) {

        ### Parse::CPAN::Meta uses exceptions for errors
        ### hash returned in list context!!!

        local $ENV{PERL_JSON_BACKEND};

        my ($doc) = eval { Parse::CPAN::Meta->load_file( $meta ) };

        unless( $doc ) {
            error(loc( "Could not read %1: '%2'", $meta, $@ ));
            return $defaults;
        }

        ### read the keys now, make sure not to throw
        ### away anything that was already added
        #for my $key ( @$keys ) {
        #    $defaults = {
        #        %$defaults,
        #        %{ $doc->{$key} },
        #    } if $doc->{ $key };
        #}
        my $prereqs = $doc->{prereqs} || {};
        for my $key ( @$keys ) {
            $defaults = {
                %$defaults,
                %{ $prereqs->{$key}->{requires} },
            } if $prereqs->{ $key }->{requires};
        }
    }

    ### and return a copy
    return \%{ $defaults };
}

sub _stash_metadata {
    my $self = shift;
    my $mod  = $self->parent;

    my @possibles = do { defined $mod->status->extract
                         ? ( META_JSON->( $mod->status->extract ),
                             META_YML->( $mod->status->extract ) )
                         : ()
                    };

    $self->mk_accessors( qw[_metadata] );
    $self->status->_metadata( {} );

    META: foreach my $mfile ( grep { -e } @possibles ) {
        if ( $mfile =~ /\.json/ ) {
            local $ENV{PERL_JSON_BACKEND};
            my ($doc) = eval { Parse::CPAN::Meta->load_file( $mfile ) };
            unless( $doc ) {
              error(loc( "Could not read %1: '%2'", $mfile, $@ ));
              return;
            }
            $self->status->_metadata( $doc );
            return $doc;
        }
        else {
            local $ENV{PERL_YAML_BACKEND};
            my ($doc) = eval { Parse::CPAN::Meta->load_file( $mfile ) };
            unless( $doc ) {
              error(loc( "Could not read %1: '%2'", $mfile, $@ ));
              return;
            }
            $self->status->_metadata( $doc );
            return $doc;
        }
    }
    return;
}


=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,$tolerant);
    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 },
        tolerant        => { default => $conf->get_conf('allow_unknown_prereqs'),
                                store => \$tolerant },
    };

    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 want 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;

    my $flag;

    for my $mod ( @sorted_prereqs ) {
        ( my $version = $prereqs->{$mod} ) =~ s#[^0-9\._]+##g;

        ### 'perl' is a special case, there's no mod object for it
        if( $mod eq PERL_CORE ) {

            unless( $cb->_vcmp( sprintf('v%vd',$^V), $version ) >= 0 ) {
                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 ) {
            # Check if it is a core module
            my $sub = CPANPLUS::Module->can(
                        'module_is_supplied_with_perl_core' );
            my $core = $sub->( $mod );
            unless ( defined $core ) {
               error( loc( "No such module '%1' found on CPAN", $mod ) );
               $flag++ unless $tolerant;
               next;
            }
            if ( $cb->_vcmp( $version, $core ) > 0 ) {
               error(loc( "Version of core module '%1' ('%2') is too low for ".
                          "'%3' (needs '%4') -- carrying on but this may be a problem",
                          $mod, $core,
                          $self->module, $version ));
            }
            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;
        }
    }

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

        ### another prereq may have already installed this one...
        ### so don't 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. -- Note that the overall ".
                      "install may fail due to this.",
                      $modobj->module, $modobj->package ) );
            next;
        }

        ### 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
    $cb->_chdir( dir => $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: