[carton] 289/472: Re-implemented carton check
Lucas Kanashiro
kanashiro-guest at moszumanska.debian.org
Fri Jul 24 00:38:56 UTC 2015
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 <miyagawa at bulknews.net>
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
More information about the Pkg-perl-cvs-commits
mailing list