diff --git a/lib/App/Pinto/Command.pm b/lib/App/Pinto/Command.pm index 8caff4ce..91569402 100644 --- a/lib/App/Pinto/Command.pm +++ b/lib/App/Pinto/Command.pm @@ -45,7 +45,7 @@ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error("Arguments are not allowed") - if @{$args} and not $self->args_attribute; + if @{$args} and not $self->args_attribute($opts, $args); return 1; } @@ -55,8 +55,8 @@ sub validate_args { sub execute { my ( $self, $opts, $args ) = @_; - my %args = $self->process_args($args); - my $result = $self->pinto->run( $self->action_name, %{$opts}, %args ); + my %processed_args = $self->process_args($opts, $args); + my $result = $self->pinto->run( $self->action_name, %{$opts}, %processed_args ); return $result->exit_status; } @@ -64,11 +64,11 @@ sub execute { #----------------------------------------------------------------------------- sub process_args { - my ( $self, $args ) = @_; + my ( $self, $opts, $args ) = @_; - my $attr_name = $self->args_attribute or return; + my $attr_name = $self->args_attribute($opts, $args) or return; - if ( !@{$args} && $self->args_from_stdin ) { + if ( !@{$args} && $self->args_from_stdin($opts, $args) ) { return ( $attr_name => [ _args_from_fh( \*STDIN ) ] ); } diff --git a/lib/App/Pinto/Command/pull.pm b/lib/App/Pinto/Command/pull.pm index 773fa34e..520707d2 100644 --- a/lib/App/Pinto/Command/pull.pm +++ b/lib/App/Pinto/Command/pull.pm @@ -31,16 +31,25 @@ sub opt_spec { [ 'stack|s=s' => 'Put packages into this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], [ 'with-development-prerequisites|wd' => 'Also pull prereqs for development' ], + [ 'cpanfile=s' => 'Name of cpanfile for pull-ees' ], ); } #------------------------------------------------------------------------------ -sub args_attribute { return 'targets' } +sub args_attribute { + my ($self, $opts, $args) = @_; + return if $opts->{cpanfile}; # expect no args if a cpanfile is supplied + return 'targets'; +} #------------------------------------------------------------------------------ -sub args_from_stdin { return 1 } +sub args_from_stdin { + my ($self, $opts, $args) = @_; + return 0 if $opts->{cpanfile}; # nothing from stdin if cpanfile supplied + return 1; +} #------------------------------------------------------------------------------ diff --git a/lib/Pinto/Action/Pull.pm b/lib/Pinto/Action/Pull.pm index ac84d4cc..2477511d 100644 --- a/lib/Pinto/Action/Pull.pm +++ b/lib/Pinto/Action/Pull.pm @@ -10,7 +10,10 @@ use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use Pinto::Util qw(throw); -use Pinto::Types qw(TargetList); +use Pinto::Types qw(File TargetList); + +use Module::CPANfile; +use Pinto::Target::Package; #------------------------------------------------------------------------------ @@ -23,11 +26,20 @@ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( - isa => TargetList, - traits => [qw(Array)], - handles => { targets => 'elements' }, - required => 1, - coerce => 1, + isa => TargetList, + traits => [qw(Array)], + handles => { + add_targets => 'push', + targets => 'elements' + }, + coerce => 1, + default => sub { [] }, +); + +has cpanfile => ( + is => 'ro', + isa => File, + coerce => 1, ); has no_fail => ( @@ -45,6 +57,12 @@ with qw( Pinto::Role::Committable Pinto::Role::Puller ); sub BUILD { my ($self) = @_; + if ( $self->cpanfile ) { + $self->_add_cpanfile_targets(); + } + + $self->targets || die "Attribute \(targets\) is required"; + $self->stack->assert_not_locked; return $self; @@ -87,6 +105,38 @@ sub execute { #------------------------------------------------------------------------------ +sub _add_cpanfile_targets { + my ($self) = @_; + + my $cpanfile = $self->cpanfile()->absolute; + + # https://metacpan.org/pod/CPAN::Meta::Spec#PREREQUISITES + my @phases = qw(configure build test runtime develop); + my @types = qw(requires recommends suggests); # exclude "conflicts" + + my $args; + try { + my $file = Module::CPANfile->load($cpanfile); + my $prereqs = $file->prereqs->merged_requirements( \@phases, \@types ); + $args = $prereqs->as_string_hash; + } + catch { + die "Unable to load requirements from $cpanfile: $_"; + }; + + for my $name ( keys %{$args} ) { + my $ptp = Pinto::Target::Package->new( + { name => $name, + version => $args->{$name} + } + ); + $self->add_targets($ptp); + } + +} + +#------------------------------------------------------------------------------ + __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ diff --git a/t/02-bowels/21-pull-with-cpanfile.t b/t/02-bowels/21-pull-with-cpanfile.t new file mode 100644 index 00000000..2dc06c94 --- /dev/null +++ b/t/02-bowels/21-pull-with-cpanfile.t @@ -0,0 +1,96 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +use lib 't/lib'; +use Pinto::Util qw(tempdir); +use Pinto::Tester; +use Pinto::Tester::Util qw(make_dist_archive); + +#------------------------------------------------------------------------------ + +my $source = Pinto::Tester->new; +$source->populate('JOHN/Baz-1.2 = Baz~1.2'); +$source->populate('PAUL/Nuts-2.3 = Nuts~2.3'); +$source->populate('RINGO/Foo-0.6 = Foo~0.6'); +$source->populate('RINGO/Loop-3.14 = Loop~3.14'); +$source->populate('GEORGE/Zap-1.0 = Zap~1.0'); +$source->populate('GEORGE/Noodle-1.008 = Noodle~1.008'); +$source->populate('GEORGE/Rose-1.8 = Rose~1.8'); + +#------------------------------------------------------------------------------ +{ + # Non-recursive pull + my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); + my $cpanfile = $local->build_cpanfile(<<"EOCPANFILE"); +requires 'Nuts', '>= 2.0, < 2.33'; +EOCPANFILE + + $local->run_ok( 'Pull', { cpanfile => $cpanfile } ); + $local->registration_ok('PAUL/Nuts-2.3/Nuts~2.3'); + $local->registration_not_ok('JOHN/Baz-1.2/Baz~1.2'); +} + +{ + # Non-recursive pull + my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); + my $cpanfile = $local->build_cpanfile(<<"EOCPANFILE"); +requires 'Nuts', '< 2.00'; +EOCPANFILE + + $local->run_throws_ok( + 'Pull', + { cpanfile => $cpanfile }, + qr/Cannot find Nuts< 2.00 anywhere/, + '... and returned expected failure message' + ); +} + +{ + # Non-recursive pull + my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); + my $cpanfile = $local->build_cpanfile(<<"EOCPANFILE"); +requires 'Nuts', '> 2.00'; +recommends 'Baz', '< 2.00'; +on 'develop' => sub { + requires 'Loop', '> 3'; + recommends 'Noodle', '> 1'; +}; +on 'test' => sub { + requires 'Zap', '>= 1.0'; + recommends 'Foo', '> 0.5'; +}; +# conflicts not currently processed +conflicts 'Rose', '< 1.0'; +EOCPANFILE + + $local->run_ok( 'Pull', { cpanfile => $cpanfile } ); + $local->registration_ok('JOHN/Baz-1.2/Baz~1.2'); + $local->registration_ok('PAUL/Nuts-2.3/Nuts~2.3'); + $local->registration_ok('RINGO/Foo-0.6/Foo~0.6'); + $local->registration_ok('RINGO/Loop-3.14/Loop~3.14'); + $local->registration_ok('GEORGE/Zap-1.0/Zap~1.0'); + $local->registration_ok('GEORGE/Noodle-1.008/Noodle~1.008'); + $local->registration_not_ok('GEORGE/Rose-1.8/Rose~1.8'); +} + +{ + # Bogus cpanfile + my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); + my $cpanfile = $local->build_cpanfile(<<"EOCPANFILE"); +# typo! +reuires 'Nuts', '> 2.00'; +EOCPANFILE + + $local->run_throws_ok( + 'Pull', + { cpanfile => $cpanfile }, + qr/Unable to load.*cpanfile/, + 'Correctly handles bogus cpanfile' + ); +} + +done_testing; diff --git a/t/02-bowels/21-pull.t b/t/02-bowels/21-pull.t index 2ecd7bd2..29cf1119 100644 --- a/t/02-bowels/21-pull.t +++ b/t/02-bowels/21-pull.t @@ -15,6 +15,14 @@ my $source = Pinto::Tester->new; $source->populate('JOHN/Baz-1.2 = Baz~1.2 & Nuts-2.3'); $source->populate('PAUL/Nuts-2.3 = Nuts~2.3'); +#------------------------------------------------------------------------------ +{ + + # Should fail with no targets + my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); + $local->run_throws_ok( 'Pull' => {}, qr/.*Attribute \(targets\) is required/ ); +} + #------------------------------------------------------------------------------ { diff --git a/t/lib/Pinto/Tester.pm b/t/lib/Pinto/Tester.pm index 41cdc897..38fec310 100644 --- a/t/lib/Pinto/Tester.pm +++ b/t/lib/Pinto/Tester.pm @@ -578,6 +578,16 @@ sub to_string { } #------------------------------------------------------------------------------ -1; +sub build_cpanfile { + my ( $self, $contents ) = @_; + + my $dir = tempdir(); + my $file = $dir->file('cpanfile'); + $file->spew($contents); + return ($file); +} + +#------------------------------------------------------------------------------1; +1; __END__