This is an automated email from the git hooks/post-receive script. kanashiro-guest pushed a commit to branch master in repository carton.
commit 5bfa6f3f18e913668d90c87e2a90bbb012335280 Author: Tatsuhiko Miyagawa <[email protected]> Date: Wed Jun 5 17:01:36 2013 +0900 Re-implemented carton check Introduced Dist::Core to represent core modules in Lock. Exit code represents the errors thrown from commands. --- cpanfile | 1 + lib/Carton/CLI.pm | 90 ++++++++++++++++++++++++++++++++++------------ lib/Carton/Dist.pm | 2 ++ lib/Carton/Dist/Core.pm | 21 +++++++++++ lib/Carton/Lock.pm | 18 ++++++++++ lib/Carton/Requirements.pm | 29 +++++++++------ script/carton | 2 +- xt/CLI.pm | 4 ++- xt/cli/check.t | 28 +++++++++++---- xt/cli/exec.t | 1 + xt/cli/no_cpanfile.t | 1 + xt/cli/tree.t | 1 + 12 files changed, 156 insertions(+), 42 deletions(-) diff --git a/cpanfile b/cpanfile index 98d3fd8..b8a7ac3 100644 --- a/cpanfile +++ b/cpanfile @@ -24,6 +24,7 @@ requires 'CPAN::Meta', 2.120921; requires 'CPAN::Meta::Requirements', 2.121; on develop => sub { + requires 'Test::More', 0.88; requires 'Test::Requires'; requires 'Capture::Tiny'; requires 'File::pushd'; diff --git a/lib/Carton/CLI.pm b/lib/Carton/CLI.pm index 082cd34..f3a5641 100644 --- a/lib/Carton/CLI.pm +++ b/lib/Carton/CLI.pm @@ -4,6 +4,11 @@ use warnings; use Config; use Getopt::Long; +use Module::CPANfile; +use Path::Tiny; +use Try::Tiny; +use Moo; +use Module::CoreList; use Carton; use Carton::Builder; @@ -12,9 +17,6 @@ use Carton::Lock; use Carton::Util; use Carton::Error; use Carton::Requirements; -use Path::Tiny; -use Try::Tiny; -use Moo; use constant { SUCCESS => 0, INFO => 1, WARN => 2, ERROR => 3 }; @@ -64,16 +66,17 @@ sub run { my $cmd = shift @commands || 'install'; my $call = $self->can("cmd_$cmd"); - if ($call) { - try { - $self->$call(@commands); - } catch { - /Carton::Error::CommandExit/ and return; - die $_; - } - } else { - $self->error("Could not find command '$cmd'\n"); - } + my $code = try { + $self->error("Could not find command '$cmd'\n") + unless $call; + $self->$call(@commands); + return 0; + } catch { + ref =~ /Carton::Error::CommandExit/ and return 255; + die $_; + }; + + return $code; } sub commands { @@ -254,20 +257,61 @@ sub cmd_tree { my $lock = $self->find_lock or $self->error("Can't find carton.lock: Run `carton install` to rebuild the lock file.\n"); - my $requirements = Carton::Requirements->new(lock => $lock, cpanfile => $self->find_cpanfile); - $requirements->walk_down(sub { $self->_dump_requirement(@_) }); -} - -sub _dump_requirement { - my($self, $dependency, $level) = @_; - $self->printf( "%s%s (%s)\n", " " x ($level - 1), $dependency->module, $dependency->distname, INFO ); + my $cpanfile = Module::CPANfile->load($self->find_cpanfile); + my $requirements = Carton::Requirements->new(lock => $lock, prereqs => $cpanfile->prereqs); + + my %seen; + my $dumper = sub { + my($dependency, $level) = @_; + return if $dependency->dist->is_perl; + return if $seen{$dependency->distname}++; + $self->printf( "%s%s (%s)\n", " " x ($level - 1), $dependency->module, $dependency->distname, INFO ); + }; + $requirements->walk_down($dumper); } sub cmd_check { my($self, @args) = @_; - die <<EOF; -carton check is not implemented yet. -EOF + + my $lock = $self->find_lock + or $self->error("Can't find carton.lock: Run `carton install` to rebuild the lock file.\n"); + + my $prereqs = Module::CPANfile->load($self->find_cpanfile)->prereqs; + + # TODO remove $lock + # TODO pass git spec to Requirements? + my $requirements = Carton::Requirements->new(lock => $lock, prereqs => $prereqs); + $requirements->walk_down(sub { }); + + my @missing; + for my $module ($requirements->all->required_modules) { + my $install = $lock->find_or_core($module); + if ($install) { + unless ($requirements->all->accepts_module($module => $install->version)) { + push @missing, [ $module, 1, $install->version ]; + } + } else { + push @missing, [ $module, 0 ]; + } + } + + if (@missing) { + $self->print("Following dependencies are not satisfied.\n", INFO); + for my $missing (@missing) { + my($module, $unsatisfied, $version) = @$missing; + if ($unsatisfied) { + $self->printf(" %s has version %s. Needs %s\n", + $module, $version, $requirements->all->requirements_for_module($module), INFO); + } else { + $self->printf(" %s is not installed. Needs %s\n", + $module, $requirements->all->requiements_for_module($module), INFO); + } + } + $self->printf("Run `carton install` to install them.\n", INFO); + Carton::Error::CommandExit->throw; + } else { + $self->print("cpanfile's dependencies are satisfied.\n", INFO); + } } sub cmd_update { diff --git a/lib/Carton/Dist.pm b/lib/Carton/Dist.pm index 2586803..fd6e663 100644 --- a/lib/Carton/Dist.pm +++ b/lib/Carton/Dist.pm @@ -11,6 +11,8 @@ has target => (is => 'ro'); has dist => (is => 'ro'); has mymeta => (is => 'ro', coerce => sub { CPAN::Meta->new($_[0], { lazy_validation => 1 }) }); +sub is_perl { 0 } + sub distfile { my $self = shift; $self->pathname; diff --git a/lib/Carton/Dist/Core.pm b/lib/Carton/Dist/Core.pm new file mode 100644 index 0000000..4c9b328 --- /dev/null +++ b/lib/Carton/Dist/Core.pm @@ -0,0 +1,21 @@ +package Carton::Dist::Core; +use strict; +use Moo; +extends 'Carton::Dist'; + +sub BUILDARGS { + my($class, %args) = @_; + + $args{dist} = "perl-$]"; + + \%args; +} + +sub is_perl { 1 } + +sub prereqs { + my $self = shift; + CPAN::Meta::Prereqs->new; +} + +1; diff --git a/lib/Carton/Lock.pm b/lib/Carton/Lock.pm index 7abd40b..c100e6f 100644 --- a/lib/Carton/Lock.pm +++ b/lib/Carton/Lock.pm @@ -2,11 +2,13 @@ package Carton::Lock; use strict; use Config; use Carton::Dist; +use Carton::Dist::Core; use Carton::Package; use Carton::Index; use Carton::Util; use CPAN::Meta; use File::Find (); +use Module::CoreList; use Moo; has version => (is => 'ro'); @@ -42,6 +44,22 @@ sub find { return; } +sub find_or_core { + my($self, $module) = @_; + $self->find($module) || $self->find_in_core($module); +} + +sub find_in_core { + my($self, $module) = @_; + + if (exists $Module::CoreList::version{$]}{$module}) { + my $version = $Module::CoreList::version{$]}{$module}; # maybe undef + return Carton::Dist::Core->new(name => $module, version => $version); + } + + return; +} + sub index { my $self = shift; diff --git a/lib/Carton/Requirements.pm b/lib/Carton/Requirements.pm index 517d861..538bf1c 100644 --- a/lib/Carton/Requirements.pm +++ b/lib/Carton/Requirements.pm @@ -3,35 +3,44 @@ use strict; use Carton::Dependency; use Moo; use CPAN::Meta::Requirements; -use Module::CPANfile; has lock => (is => 'ro'); -has cpanfile => (is => 'ro', coerce => sub { Module::CPANfile->load($_[0]) }); +has prereqs => (is => 'ro'); +has all => (is => 'ro', default => sub { CPAN::Meta::Requirements->new }); sub walk_down { my($self, $cb) = @_; my $dumper; $dumper = sub { - my($dependency, $prereqs, $level, $seen) = @_; + my($dependency, $prereqs, $level, $parent) = @_; $cb->($dependency, $level) if $dependency; + my @phase = qw( configure build runtime ); + push @phase, 'test' unless $dependency; + my $reqs = CPAN::Meta::Requirements->new; - $reqs->add_requirements($prereqs->requirements_for($_, 'requires')) - for qw( configure build runtime test); + $reqs->add_requirements($prereqs->requirements_for($_, 'requires')) for @phase; + $reqs->clear_requirement('perl'); # for now + + $self->all->add_requirements($reqs) unless $self->all->is_finalized; + + local $parent->{$dependency->distname} = 1 if $dependency; for my $module (sort $reqs->required_modules) { my $dependency = $self->dependency_for($module, $reqs); if ($dependency->dist) { - next if $seen->{$dependency->distname}++; - $dumper->($dependency, $dependency->prereqs, $level + 1, $seen); + next if $parent->{$dependency->distname}; + $dumper->($dependency, $dependency->prereqs, $level + 1); } else { - # no dist found in lock - probably core + # no dist found in lock } } }; - $dumper->(undef, $self->cpanfile->prereqs, 0, {}); + $dumper->(undef, $self->prereqs, 0, {}); + + $self->all->finalize; } sub dependency_for { @@ -43,7 +52,7 @@ sub dependency_for { $dep->module($module); $dep->requirement($requirement); - if (my $dist = $self->lock->find($module)) { + if (my $dist = $self->lock->find_or_core($module)) { $dep->dist($dist); } diff --git a/script/carton b/script/carton index 39173f0..3dca242 100755 --- a/script/carton +++ b/script/carton @@ -3,4 +3,4 @@ use strict; use 5.008001; use Carton::CLI; -Carton::CLI->new->run(@ARGV); +exit Carton::CLI->new->run(@ARGV); diff --git a/xt/CLI.pm b/xt/CLI.pm index 82baf95..502ea2e 100644 --- a/xt/CLI.pm +++ b/xt/CLI.pm @@ -24,6 +24,7 @@ $Carton::CLI::UseSystem = 1; has dir => (is => 'rw'); has stdout => (is => 'rw'); has stderr => (is => 'rw'); +has exit_code => (is => 'rw'); sub run { my($self, @args) = @_; @@ -31,7 +32,8 @@ sub run { my $pushd = File::pushd::pushd $self->dir; my @capture = capture { - eval { $self->SUPER::run(@args) }; + my $code = $self->SUPER::run(@args); + $self->exit_code($code); }; $self->stdout($capture[0]); diff --git a/xt/cli/check.t b/xt/cli/check.t index 9d75773..51d7616 100644 --- a/xt/cli/check.t +++ b/xt/cli/check.t @@ -2,26 +2,40 @@ use strict; use Test::More; use xt::CLI; -plan skip_all => "check is unimplemented"; - { my $app = cli(); $app->dir->child("cpanfile")->spew(<<EOF); -requires 'Try::Tiny'; +requires 'Try::Tiny', '== 0.11'; EOF $app->run("check"); - like $app->stdout, qr/Following dependencies are not satisfied.*Try::Tiny/s; - unlike $app->stdout, qr/found in local but/; + like $app->stderr, qr/find carton\.lock/; + + $app->run("install"); + + $app->run("check"); + like $app->stdout, qr/are satisfied/; + + $app->run("list"); + like $app->stdout, qr/Try-Tiny-0\.11/; + + $app->dir->child("cpanfile")->spew(<<EOF); +requires 'Try::Tiny', '0.12'; +EOF + + $app->run("check"); + like $app->stdout, qr/not satisfied/; + + # TODO run exec and it will fail again $app->run("install"); $app->run("check"); - like $app->stdout, qr/matches/; + like $app->stdout, qr/are satisfied/; $app->run("list"); - like $app->stdout, qr/Try-Tiny-/; + like $app->stdout, qr/Try-Tiny-0\.12/; } diff --git a/xt/cli/exec.t b/xt/cli/exec.t index 99d1a29..bd3ab28 100644 --- a/xt/cli/exec.t +++ b/xt/cli/exec.t @@ -6,6 +6,7 @@ use xt::CLI; my $app = cli(); $app->run("exec", "perl", "-e", 1); like $app->stderr, qr/carton\.lock/; + is $app->exit_code, 255; } { diff --git a/xt/cli/no_cpanfile.t b/xt/cli/no_cpanfile.t index 5c47f15..e12d2c3 100644 --- a/xt/cli/no_cpanfile.t +++ b/xt/cli/no_cpanfile.t @@ -6,6 +6,7 @@ use xt::CLI; my $app = cli(); $app->run("install"); like $app->stderr, qr/Can't locate cpanfile/; + is $app->exit_code, 255; } done_testing; diff --git a/xt/cli/tree.t b/xt/cli/tree.t index 69eb30e..15c56bf 100644 --- a/xt/cli/tree.t +++ b/xt/cli/tree.t @@ -12,6 +12,7 @@ EOF $app->run("install"); $app->run("tree"); + is $app->exit_code, 0; like $app->stdout, qr/^HTML::Parser \(HTML-Parser-/m; like $app->stdout, qr/^ HTML::Tagset \(HTML-Tagset-/m; } -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/carton.git _______________________________________________ Pkg-perl-cvs-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
