This is an automated email from the git hooks/post-receive script.
kanashiro-guest pushed a commit to branch master
in repository carton.
commit 4e40539f6e4dd38b10eca90d03e8ea2b546dc8b9
Author: Tatsuhiko Miyagawa <miyag...@bulknews.net>
Date: Mon Jul 22 12:12:09 2013 -0700
introduce Carton::Environment object
use Exception::Class more for error messaging
---
lib/Carton/CLI.pm | 47 +++++++++++++++------------------
lib/Carton/Environment.pm | 66 +++++++++++++++++++++++++++++++++++++++++++++++
lib/Carton/Error.pm | 6 +++--
xt/cli/exec.t | 8 ++++++
4 files changed, 99 insertions(+), 28 deletions(-)
diff --git a/lib/Carton/CLI.pm b/lib/Carton/CLI.pm
index 062c6f6..c9ecf29 100644
--- a/lib/Carton/CLI.pm
+++ b/lib/Carton/CLI.pm
@@ -9,12 +9,14 @@ use Path::Tiny;
use Try::Tiny;
use Moo;
use Module::CoreList;
+use Scalar::Util qw(blessed);
use Carton;
use Carton::Builder;
use Carton::Mirror;
use Carton::Lock;
use Carton::Util;
+use Carton::Environment;
use Carton::Error;
use Carton::Requirements;
@@ -26,14 +28,16 @@ has verbose => (is => 'rw');
has carton => (is => 'lazy');
has mirror => (is => 'rw', builder => 1,
coerce => sub { Carton::Mirror->new($_[0]) });
+has environment => (is => 'lazy',
+ handles => [ qw( cpanfile lockfile install_path
vendor_cache )]);
sub _build_mirror {
my $self = shift;
$ENV{PERL_CARTON_MIRROR} || $Carton::Mirror::DefaultMirror;
}
-sub install_path {
- Path::Tiny->new($ENV{PERL_CARTON_PATH} || 'local')->absolute;
+sub _build_environment {
+ Carton::Environment->build;
}
sub work_file {
@@ -43,10 +47,6 @@ sub work_file {
$wf;
}
-sub vendor_cache {
- Path::Tiny->new("vendor/cache")->absolute;
-}
-
sub run {
my($self, @args) = @_;
@@ -64,16 +64,21 @@ sub run {
push @commands, @args;
my $cmd = shift @commands || 'install';
- my $call = $self->can("cmd_$cmd");
my $code = try {
- $self->error("Could not find command '$cmd'\n")
- unless $call;
+ my $call = $self->can("cmd_$cmd")
+ or Carton::Error::CommandNotFound->throw(error => "Could not find
command '$cmd'");
$self->$call(@commands);
return 0;
} catch {
- ref =~ /Carton::Error::CommandExit/ and return 255;
- die $_;
+ die $_ unless blessed $_ && $_->can('rethrow');
+
+ if ($_->isa('Carton::Error::CommandExit')) {
+ return $_->code || 255;
+ } elsif ($_->isa('Carton::Error')) {
+ warn $_->error;
+ return 255;
+ }
};
return $code;
@@ -220,7 +225,7 @@ sub cmd_install {
unless ($deployment) {
my $prereqs = Module::CPANfile->load($cpanfile)->prereqs;
- Carton::Lock->build_from_local($path,
$prereqs)->write($self->lock_file);
+ Carton::Lock->build_from_local($path,
$prereqs)->write($self->lockfile);
}
$self->print("Complete! Modules were installed into $path\n", SUCCESS);
@@ -348,7 +353,7 @@ sub cmd_update {
);
$builder->update($self->install_path, @modules);
- Carton::Lock->build_from_local($self->install_path,
$prereqs)->write($self->lock_file);
+ Carton::Lock->build_from_local($self->install_path,
$prereqs)->write($self->lockfile);
}
sub cmd_exec {
@@ -385,21 +390,16 @@ sub cmd_exec {
sub find_cpanfile {
my $self = shift;
-
- if (-e 'cpanfile') {
- return 'cpanfile';
- } else {
- $self->error("Can't locate cpanfile\n");
- }
+ $self->cpanfile;
}
sub find_lock {
my $self = shift;
- if (-e $self->lock_file) {
+ if (-e $self->lockfile) {
my $lock;
try {
- $lock = Carton::Lock->from_file($self->lock_file);
+ $lock = Carton::Lock->from_file($self->lockfile);
} catch {
$self->error("Can't parse carton.lock: $_\n");
};
@@ -410,11 +410,6 @@ sub find_lock {
return;
}
-sub lock_file {
- my $self = shift;
- return 'carton.lock';
-}
-
sub index_file {
my $self = shift;
$self->work_file("cache/modules/02packages.details.txt");
diff --git a/lib/Carton/Environment.pm b/lib/Carton/Environment.pm
new file mode 100644
index 0000000..af39f4d
--- /dev/null
+++ b/lib/Carton/Environment.pm
@@ -0,0 +1,66 @@
+package Carton::Environment;
+use strict;
+use Moo;
+
+use Carton::Error;
+use Path::Tiny;
+
+has cpanfile => (is => 'rw');
+has lockfile => (is => 'lazy');
+has install_path => (is => 'lazy');
+has vendor_cache => (is => 'lazy');
+
+sub _build_lockfile {
+ my $self = shift;
+ Path::Tiny->new($self->cpanfile->dirname . "/carton.lock");
+}
+
+sub _build_install_path {
+ my $self = shift;
+ if ($ENV{PERL_CARTON_PATH}) {
+ return Path::Tiny->new($ENV{PERL_CARTON_PATH})->absolute;
+ } else {
+ return Path::Tiny->new($self->cpanfile->dirname . "/local");
+ }
+}
+
+sub _build_vendor_cache {
+ my $self = shift;
+ Path::Tiny->new($self->install_path->dirname . "/vendor/cache");
+}
+
+sub build {
+ my $class = shift;
+
+ my $self = $class->new;
+
+ if (my $cpanfile = $self->locate_cpanfile) {
+ $self->cpanfile($cpanfile);
+ } else {
+ Carton::Error::CPANfileNotFound->throw(error => "Can't locate
cpanfile");
+ }
+
+ $self;
+}
+
+sub locate_cpanfile {
+ my $self = shift;
+
+ my $current = Path::Tiny->cwd;
+ my $previous = '';
+
+ until ($current eq '/' or $current eq $previous) {
+ # TODO support PERL_CARTON_CPANFILE
+ my $try = $current->child('cpanfile');
+ if ($try->exists) {
+ return $try->absolute;
+ }
+
+ ($previous, $current) = ($current, $current->parent);
+ }
+
+ return;
+}
+
+1;
+
diff --git a/lib/Carton/Error.pm b/lib/Carton/Error.pm
index 30b9882..24af647 100644
--- a/lib/Carton/Error.pm
+++ b/lib/Carton/Error.pm
@@ -1,8 +1,10 @@
package Carton::Error;
use strict;
use Exception::Class (
- 'Carton::Error::CommandExit',
+ 'Carton::Error',
+ 'Carton::Error::CommandNotFound' => { isa => 'Carton::Error' },
+ 'Carton::Error::CommandExit' => { isa => 'Carton::Error', fields => [
'code' ] },
+ 'Carton::Error::CPANfileNotFound' => { isa => 'Carton::Error' },
);
-
1;
diff --git a/xt/cli/exec.t b/xt/cli/exec.t
index 40b1055..72fe864 100644
--- a/xt/cli/exec.t
+++ b/xt/cli/exec.t
@@ -11,8 +11,16 @@ subtest 'carton exec without a command', sub {
is $app->exit_code, 255;
};
+subtest 'exec without cpanfile', sub {
+ my $app = cli();
+ $app->run("exec", "perl", "-e", 1);
+ like $app->stderr, qr/Can't locate cpanfile/;
+ is $app->exit_code, 255;
+};
+
subtest 'exec without a lock', sub {
my $app = cli();
+ $app->write_cpanfile();
$app->run("exec", "perl", "-e", 1);
like $app->stderr, qr/carton\.lock/;
is $app->exit_code, 255;
--
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
