File Coverage

blib/lib/Pinto/Role/Puller.pm

Criterion	Covered	Total	%
statement	77	78	98.7
branch	31	34	91.1
condition	2	3	66.6
subroutine	13	13	100.0
pod	0	4	0.0
total	123	132	93.1

# ABSTRACT: Something pulls packages to a stack

package Pinto::Role::Puller;

use Moose::Role;
use MooseX::Types::Moose qw(ArrayRef Bool Str);
use MooseX::MarkAsMethods ( autoclean => 1 );

use List::MoreUtils qw(any);

use Pinto::Util qw(throw whine);

#-----------------------------------------------------------------------------

our $VERSION = '0.14'; # VERSION

#-----------------------------------------------------------------------------

with qw( Pinto::Role::Plated );

#-----------------------------------------------------------------------------

has recurse => (
    is      => 'ro',
    isa     => Bool,
    default => sub { shift->stack->repo->config->recurse },
    lazy    => 1,
);

has cascade => (
    is      => 'ro',
    isa     => Bool,
    default => 0,
);

has pin => (
    is      => 'ro',
    isa     => Bool,
    default => 0,
);

has force => (
    is      => 'ro',
    isa     => Bool,
    default => 0,
);

has skip_missing_prerequisite => (
    is        => 'ro',
    isa       => ArrayRef[Str],
    default   => sub { [] },
);

has skip_all_missing_prerequisites => (
    is        => 'ro',
    isa       => Bool,
    default   => 0,
);

has with_development_prerequisites => (
    is      => 'ro',
    isa     => Bool,
    default => 0,
);

#-----------------------------------------------------------------------------

# We should require a stack() attribute here, but Moose can't properly
# resolve attributes that are composed from other roles.  For more info
# see https://rt.cpan.org/Public/Bug/Display.html?id=46347

# requires qw(stack);

#-----------------------------------------------------------------------------

sub pull {
    my ( $self, %args ) = @_;

    my $target = $args{target};
    my $stack  = $self->stack;

    my $did_register         = 0;
    my $did_register_prereqs = 0;
    my $dist;

    if ( $target->isa('Pinto::Schema::Result::Distribution') ) {
        $dist = $target;
    }
    elsif ( $target->isa('Pinto::Target::Distribution') ) {
        $dist = $self->find( target => $target );
    }
    elsif ( $target->isa('Pinto::Target::Package') ) {

        my $tpv = $stack->target_perl_version;
        if ( $target->is_core( in => $tpv ) ) {
            $self->warning("Skipping $target: included in perl $tpv core");
            return (undef, 0, 0); # Nothing was pulled
        }

        $dist = $self->find( target => $target );
    }
    else {
        throw "Illeagal arguments";
    }

    $did_register = $dist->register( stack => $stack, pin => $self->pin, force => $self->force );
    $did_register_prereqs = $self->do_recursion( start => $dist ) if $self->recurse;

    return ($dist, $did_register, $did_register_prereqs);
}

#-----------------------------------------------------------------------------

sub find {
    my ( $self, %args ) = @_;

    my $target = $args{target};
    my $stack  = $self->stack;

    my $dist;
    my $msg;

    if ( $dist = $stack->get_distribution( target => $target ) ) {
        $msg = "Found $target on stack $stack in $dist";
    }
    elsif ( $dist = $stack->repo->get_distribution( target => $target ) ) {
        $msg = "Found $target in $dist";
    }
    elsif ( $dist = $stack->repo->ups_distribution( target => $target, cascade => $self->cascade ) ) {
        $msg = "Found $target in " . $dist->source;
    }
    elsif ( $self->should_skip_missing_prerequisite($target) ) {
        whine "Cannot find $target anywhere.  Skipping it";
        return;
    }
    else {
        throw "Cannot find $target anywhere";
    }

    $self->chrome->show_progress;
    $self->info($msg) if defined $msg;

    return $dist;
}

#-----------------------------------------------------------------------------

sub do_recursion {
    my ( $self, %args ) = @_;

    my $dist  = $args{start};
    my $stack = $self->stack;

    my %last_seen;
    my $did_register = 0;

    my $cb = sub {
        my ($prereq) = @_;

        my $target   = $prereq->as_target;
        my $pkg_name = $target->name;
        my $pkg_vers = $target->version;

        # version sees undef and 0 as equal, so must also check definedness
        # when deciding if we've seen this version (or newer) of the package
        return if defined( $last_seen{$pkg_name} ) && $target->is_satisfied_by( $last_seen{$pkg_name} );

        return if not my $dist = $self->find( target => $target );

        $did_register += $dist->register( stack => $stack, force => $self->force);

        # Record the most recent version of the packages that has
        # been registered, so we don't need to find it again.
        $last_seen{$_->name} = $_->version for $dist->packages;

        return $dist;
    };

    # Exclude perl itself, and prereqs that are satisfied by the core
    my @filters = ( sub { $_[0]->is_perl || $_[0]->is_core( in => $stack->target_perl_version ) } );

    # Exlucde develop-time dependencies, unless asked not to
    push @filters, sub { $_[0]->phase eq 'develop' }
        unless $self->with_development_prerequisites;

    require Pinto::PrerequisiteWalker;
    my $walker = Pinto::PrerequisiteWalker->new( start => $dist, callback => $cb, filters => \@filters );

    $self->notice("Descending into prerequisites for $dist");

    while ( $walker->next ) { };    # Just want the callback side effects

    return $did_register;
}

#-----------------------------------------------------------------------------

sub should_skip_missing_prerequisite {
    my ($self, $target) = @_;

    return 1 if $self->skip_all_missing_prerequisites;
    return 0 unless my @skips = @{ $self->skip_missing_prerequisite };
    return 1 if any { $target->name eq $_ } @skips;
    return 0;
}

#-----------------------------------------------------------------------------
1;

__END__

=pod

=encoding UTF-8

=for :stopwords Jeffrey Ryan Thalhammer

=head1 NAME

Pinto::Role::Puller - Something pulls packages to a stack

=head1 VERSION

version 0.14

=head1 AUTHOR

Jeffrey Ryan Thalhammer <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut