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 <miyag...@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

_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits

Reply via email to