[carton] 26/472: Some refactorings
Lucas Kanashiro
kanashiro-guest at moszumanska.debian.org
Fri Jul 24 00:38:28 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 23c50aec4eaed33819c3537d48cbe3995284bd14
Author: Tatsuhiko Miyagawa <miyagawa at bulknews.net>
Date: Sun Jun 26 00:10:30 2011 -0700
Some refactorings
---
bin/carton | 4 +-
lib/Carton.pm | 272 ++++++++---------------------------------------------
lib/Carton/CLI.pm | 235 +++++++++++++++++++++++++++++++++++++++++++++
lib/Carton/Util.pm | 15 +++
4 files changed, 291 insertions(+), 235 deletions(-)
diff --git a/bin/carton b/bin/carton
index d72a74c..39173f0 100755
--- a/bin/carton
+++ b/bin/carton
@@ -1,6 +1,6 @@
#!perl
use strict;
use 5.008001;
-use Carton;
+use Carton::CLI;
-Carton->new->run(@ARGV);
+Carton::CLI->new->run(@ARGV);
diff --git a/lib/Carton.pm b/lib/Carton.pm
index 8bdf018..4a8c165 100644
--- a/lib/Carton.pm
+++ b/lib/Carton.pm
@@ -1,201 +1,57 @@
package Carton;
use strict;
+use warnings;
use 5.008_001;
use version; our $VERSION = qv('v0.1.0');
-use Cwd;
-use Config;
-use Getopt::Long;
-use Term::ANSIColor qw(colored);
-
-use Carton::Tree;
-
-our $Colors = {
- SUCCESS => 'green',
- INFO => 'cyan',
- ERROR => 'red',
-};
+use Carton::Util;
sub new {
my $class = shift;
bless {
- path => 'local',
- color => 1,
- verbose => 0,
cpanm => $ENV{PERL_CARTON_CPANM} || 'cpanm',
}, $class;
}
-sub work_file {
- my($self, $file) = @_;
- return "$self->{work_dir}/$file";
-}
-
-sub run {
- my($self, @args) = @_;
-
- $self->{work_dir} = $ENV{PERL_CARTON_HOME} || (Cwd::cwd() . "/.carton");
- mkdir $self->{work_dir}, 0777 unless -e $self->{work_dir};
-
- local @ARGV = @args;
- my @commands;
- my $p = Getopt::Long::Parser->new(
- config => [ "no_ignore_case", "pass_through" ],
- );
- $p->getoptions(
- "h|help" => sub { unshift @commands, 'help' },
- "v|version" => sub { unshift @commands, 'version' },
- "color!" => \$self->{color},
- "verbose!" => \$self->{verbose},
- );
-
- push @commands, @ARGV;
-
- my $cmd = shift @commands || 'usage';
- my $call = $self->can("cmd_$cmd");
-
- if ($call) {
- $self->$call(@commands);
- } else {
- die "Could not find command '$cmd'\n";
- }
-}
-
-sub commands {
- my $self = shift;
-
- no strict 'refs';
- map { s/^cmd_//; $_ }
- grep /^cmd_(.*)/, sort keys %{__PACKAGE__."::"};
-}
-
-sub cmd_usage {
- my $self = shift;
- print <<HELP;
-Usage: carton <command>
-
-where <command> is one of:
- @{[ join ", ", $self->commands ]}
-
-Run carton -h <command> for help.
-HELP
-}
-
-sub parse_options {
- my($self, $args, @spec) = @_;
- Getopt::Long::GetOptionsFromArray($args, @spec);
-}
-
-sub print {
- my($self, $msg, $type) = @_;
- $msg = colored $msg, $Colors->{$type} if $type && $self->{color};
- print $msg;
-}
-
-sub check {
- my($self, $msg) = @_;
- $self->print("✓ ", "SUCCESS");
- $self->print($msg . "\n");
-}
-
-sub error {
- my($self, $msg) = @_;
- $self->print($msg, "ERROR");
- exit(1);
-}
-
-sub cmd_help {
- my $self = shift;
- my $module = "Carton::Doc::" . ($_[0] ? ucfirst $_[0] : "Carton");
- system "perldoc", $module;
-}
-
-sub cmd_version {
- print "carton $VERSION\n";
-}
-
-sub cmd_install {
- my($self, @args) = @_;
-
- $self->parse_options(\@args, "p|path=s", \$self->{path}, "deployment!" => \$self->{deployment});
-
- if (@args) {
- $self->print("Installing modules from the command line\n");
- $self->install_modules(@args);
- $self->update_packages;
- } elsif (my $file = $self->has_build_file) {
- $self->print("Installing modules using $file\n");
- $self->install_from_build_file($file);
- $self->update_packages;
- } elsif (-e 'carton.lock') {
- $self->print("Installing modules using carton.lock\n");
- $self->install_from_spec();
- } else {
- $self->error("Can't locate build file or carton.lock\n");
- }
-
- $self->print("Complete! Modules were installed into $self->{path}\n", "SUCCESS");
-}
-
-sub has_build_file {
- my $self = shift;
-
- # deployment mode ignores build files and only uses carton.lock
- return if $self->{deployment};
-
- my $file = (grep -e, qw( Build.PL Makefile.PL ))[0]
- or return;
-
- if ($self->mtime($file) > $self->mtime("carton.lock")) {
- return $file;
- }
-
- return;
-}
-
-sub mtime {
- my($self, $file) = @_;
- return (stat($file))[9] || 0;
+sub configure_cpanm {
+ my($self, %args) = @_;
+ $self->{path} = $args{path};
}
sub install_from_build_file {
my($self, $file) = @_;
$self->run_cpanm("--installdeps", ".")
- or $self->error("Installing modules failed\n");
+ or die "Installing modules failed\n";
}
sub install_modules {
- my($self, @args) = @_;
- $self->run_cpanm(@args)
- or $self->error("Installing modules failed\n");
+ my($self, $modules) = @_;
+ $self->run_cpanm(@$modules)
+ or die "Installing modules failed\n";
}
-sub install_from_spec {
- my $self = shift;
-
- my $data = $self->parse_json('carton.lock')
- or $self->error("Couldn't parse carton.lock: Remove the file and run `carton install` to rebuild it.\n");
+sub install_from_lock {
+ my($self, $lock, $mirror_file) = @_;
- my $index = $self->build_index($data->{modules});
- my $file = $self->build_mirror_file($index);
+ my $index = $self->build_index($lock->{modules});
+ $self->build_mirror_file($index, $mirror_file);
- my $tree = $self->build_tree($data->{modules});
+ my $tree = $self->build_tree($lock->{modules});
my @root = map $_->key, $tree->children;
$self->run_cpanm(
"--mirror", "http://backpan.perl.org/",
"--mirror", "http://cpan.cpantesters.org/",
- "--index", $file, @root,
+ "--index", $mirror_file, @root,
);
}
sub build_mirror_file {
- my($self, $index) = @_;
+ my($self, $index, $file) = @_;
my @packages = $self->build_packages($index);
- my $file = $self->work_file("02packages.details.txt");
open my $fh, ">", $file or die $!;
print $fh <<EOF;
@@ -238,40 +94,6 @@ sub build_packages {
return @packages;
}
-*cmd_list = \&cmd_show;
-
-sub cmd_show {
- my($self, @args) = @_;
-
- require Module::CoreList;
-
- my $tree_mode;
- $self->parse_options(\@args, "tree!" => \$tree_mode);
-
- my $data = $self->parse_json('carton.lock')
- or $self->error("Can't find carton.lock: Run `carton install` to rebuild the spec file.\n");
-
- if ($tree_mode) {
- my %seen;
- my $tree = $self->build_tree($data->{modules});
- $tree->walk_down(sub {
- my($node, $depth, $parent) = @_;
-
- return $tree->abort if $seen{$node->key}++;
-
- if ($node->metadata->{dist}) {
- print " " x $depth;
- print $node->metadata->{dist}, "\n";
- } elsif (!$Module::CoreList::version{$]+0}{$node->key}) {
- warn "Couldn't find ", $node->key, "\n";
- }
- });
- } else {
- for my $module (values %{$data->{modules} || {}}) {
- printf "$module->{dist}\n";
- }
- }
-}
sub build_index {
my($self, $modules) = @_;
@@ -289,6 +111,25 @@ sub build_index {
return $index;
}
+sub walk_down_tree {
+ my($self, $lock, $cb) = @_;
+
+ require Module::CoreList;
+
+ my %seen;
+ my $tree = $self->build_tree($lock->{modules});
+ $tree->walk_down(sub {
+ my($node, $depth, $parent) = @_;
+ return $tree->abort if $seen{$node->key}++;
+
+ if ($node->metadata->{dist}) {
+ $cb->($node->metadata, $depth);
+ } elsif (!$Module::CoreList::version{$]+0}{$node->key}) {
+ warn "Couldn't find ", $node->key, "\n";
+ }
+ });
+}
+
sub build_tree {
my($self, $modules) = @_;
@@ -340,49 +181,14 @@ sub build_deps {
return @deps;
}
-sub cmd_check {
- my $self = shift;
-
- $self->check_cpanm_version;
- # check carton.lock and extlib?
-}
-
-sub check_cpanm_version {
- my $self = shift;
-
- my $version = (`$self->{cpanm} --version` =~ /version (\S+)/)[0];
- unless ($version && $version >= 1.5) {
- $self->error("carton needs cpanm version >= 1.5. You have " . ($version || "(not installed)") . "\n");
- }
- $self->check("You have cpanm $version");
-}
-
-sub cmd_update {
- # "cleanly" update distributions in extlib
- # rebuild the tree, update modules with DFS
-}
-
-sub cmd_exec {
- # setup lib::core::only, -L env, put extlib/bin into PATH and exec script
-}
-
sub run_cpanm {
my($self, @args) = @_;
local $ENV{PERL_CPANM_OPT};
- !system $self->{cpanm}, "--quiet", "--notest", "-L", $self->{path}, @args;
-}
-
-sub parse_json {
- my($self, $file) = @_;
-
- open my $fh, "<", $file or return;
-
- require JSON;
- JSON::decode_json(join '', <$fh>);
+ !system $self->{cpanm}, "--quiet", "-L", $self->{path}, "--notest", @args;
}
sub update_packages {
- my $self = shift;
+ my($self, $file) = @_;
my %locals = $self->find_locals;
@@ -410,8 +216,8 @@ sub find_locals {
};
File::Find::find($wanted, "$self->{path}/lib/perl5/auto/meta");
- return map { my $module = $self->parse_json($_); ($module->{name} => $module) } @locals;
+ return map { my $module = Carton::Util::parse_json($_); ($module->{name} => $module) } @locals;
}
1;
-__END__
+
diff --git a/lib/Carton/CLI.pm b/lib/Carton/CLI.pm
new file mode 100644
index 0000000..4a77bc4
--- /dev/null
+++ b/lib/Carton/CLI.pm
@@ -0,0 +1,235 @@
+package Carton::CLI;
+use strict;
+use warnings;
+
+use Carton;
+use Carton::Util;
+
+use Cwd;
+use Config;
+use Getopt::Long;
+use Term::ANSIColor qw(colored);
+
+use Carton::Tree;
+
+our $Colors = {
+ SUCCESS => 'green',
+ INFO => 'cyan',
+ ERROR => 'red',
+};
+
+sub new {
+ my $class = shift;
+ bless {
+ path => 'local',
+ color => 1,
+ verbose => 0,
+ carton => Carton->new,
+ }, $class;
+}
+
+sub carton { $_[0]->{carton} }
+
+sub work_file {
+ my($self, $file) = @_;
+ return "$self->{work_dir}/$file";
+}
+
+sub run {
+ my($self, @args) = @_;
+
+ $self->{work_dir} = $ENV{PERL_CARTON_HOME} || (Cwd::cwd() . "/.carton");
+ mkdir $self->{work_dir}, 0777 unless -e $self->{work_dir};
+
+ local @ARGV = @args;
+ my @commands;
+ my $p = Getopt::Long::Parser->new(
+ config => [ "no_ignore_case", "pass_through" ],
+ );
+ $p->getoptions(
+ "h|help" => sub { unshift @commands, 'help' },
+ "v|version" => sub { unshift @commands, 'version' },
+ "color!" => \$self->{color},
+ "verbose!" => \$self->{verbose},
+ );
+
+ push @commands, @ARGV;
+
+ my $cmd = shift @commands || 'usage';
+ my $call = $self->can("cmd_$cmd");
+
+ if ($call) {
+ $self->$call(@commands);
+ } else {
+ die "Could not find command '$cmd'\n";
+ }
+}
+
+sub commands {
+ my $self = shift;
+
+ no strict 'refs';
+ map { s/^cmd_//; $_ }
+ grep /^cmd_(.*)/, sort keys %{__PACKAGE__."::"};
+}
+
+sub cmd_usage {
+ my $self = shift;
+ print <<HELP;
+Usage: carton <command>
+
+where <command> is one of:
+ @{[ join ", ", $self->commands ]}
+
+Run carton -h <command> for help.
+HELP
+}
+
+sub parse_options {
+ my($self, $args, @spec) = @_;
+ Getopt::Long::GetOptionsFromArray($args, @spec);
+}
+
+sub print {
+ my($self, $msg, $type) = @_;
+ $msg = colored $msg, $Colors->{$type} if $type && $self->{color};
+ print $msg;
+}
+
+sub check {
+ my($self, $msg) = @_;
+ $self->print("✓ ", "SUCCESS");
+ $self->print($msg . "\n");
+}
+
+sub error {
+ my($self, $msg) = @_;
+ $self->print($msg, "ERROR");
+ exit(1);
+}
+
+sub cmd_help {
+ my $self = shift;
+ my $module = "Carton::Doc::" . ($_[0] ? ucfirst $_[0] : "Carton");
+ system "perldoc", $module;
+}
+
+sub cmd_version {
+ print "carton $Carton::VERSION\n";
+}
+
+sub cmd_install {
+ my($self, @args) = @_;
+
+ $self->parse_options(\@args, "p|path=s", \$self->{path}, "deployment!" => \$self->{deployment});
+ $self->carton->configure_cpanm(path => $self->{path});
+
+ if (@args) {
+ $self->print("Installing modules from the command line\n");
+ $self->carton->install_modules(\@args);
+ $self->carton->update_packages($self->lock_file);
+ } elsif (my $file = $self->has_build_file) {
+ $self->print("Installing modules using $file\n");
+ $self->carton->install_from_build_file($file);
+ $self->carton->update_packages($self->lock_file);
+ } elsif (-e $self->lock_file) {
+ $self->print("Installing modules using carton.lock\n");
+ $self->carton->install_from_lock($self->lock_data, $self->mirror_file);
+ } else {
+ $self->error("Can't locate build file or carton.lock\n");
+ }
+
+ $self->print("Complete! Modules were installed into $self->{path}\n", "SUCCESS");
+}
+
+sub mirror_file {
+ my $self = shift;
+ return $self->work_file("02packages.details.txt");
+}
+
+sub has_build_file {
+ my $self = shift;
+
+ # deployment mode ignores build files and only uses carton.lock
+ return if $self->{deployment};
+
+ my $file = (grep -e, qw( Build.PL Makefile.PL ))[0]
+ or return;
+
+ if ($self->mtime($file) > $self->mtime($self->lock_file)) {
+ return $file;
+ }
+
+ return;
+}
+
+sub mtime {
+ my($self, $file) = @_;
+ return (stat($file))[9] || 0;
+}
+
+*cmd_list = \&cmd_show;
+
+sub cmd_show {
+ my($self, @args) = @_;
+
+ my $tree_mode;
+ $self->parse_options(\@args, "tree!" => \$tree_mode);
+
+ my $lock = $self->lock_data
+ or $self->error("Can't find carton.lock: Run `carton install` to rebuild the spec file.\n");
+
+
+ if ($tree_mode) {
+ $self->carton->walk_down_tree($lock, sub {
+ my($module, $depth) = @_;
+ print " " x $depth;
+ print "$module->{dist}\n";
+ });
+ } else {
+ for my $module (values %{$lock->{modules} || {}}) {
+ printf "$module->{dist}\n";
+ }
+ }
+}
+
+sub cmd_check {
+ my $self = shift;
+
+ $self->check_cpanm_version;
+ # check carton.lock and extlib?
+}
+
+sub check_cpanm_version {
+ my $self = shift;
+
+ my $version = (`$self->{cpanm} --version` =~ /version (\S+)/)[0];
+ unless ($version && $version >= 1.5) {
+ $self->error("carton needs cpanm version >= 1.5. You have " . ($version || "(not installed)") . "\n");
+ }
+ $self->check("You have cpanm $version");
+}
+
+sub cmd_update {
+ # "cleanly" update distributions in extlib
+ # rebuild the tree, update modules with DFS
+}
+
+sub cmd_exec {
+ # setup lib::core::only, -L env, put extlib/bin into PATH and exec script
+}
+
+sub lock_data {
+ my $self = shift;
+ $self->{lock} || do {
+ Carton::Util::parse_json($self->lock_file);
+ };
+}
+
+sub lock_file {
+ my $self = shift;
+ return 'carton.lock';
+}
+
+
+1;
diff --git a/lib/Carton/Util.pm b/lib/Carton/Util.pm
new file mode 100644
index 0000000..519feb5
--- /dev/null
+++ b/lib/Carton/Util.pm
@@ -0,0 +1,15 @@
+package Carton::Util;
+use strict;
+use warnings;
+
+sub parse_json {
+ my $file = shift;
+
+ open my $fh, "<", $file or die "$file: $!";
+
+ require JSON;
+ JSON::decode_json(join '', <$fh>);
+}
+
+1;
+
--
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