Permalink
Browse files

Some refactorings

  • Loading branch information...
1 parent d3ea4e0 commit 23c50aec4eaed33819c3537d48cbe3995284bd14 @miyagawa miyagawa committed Jun 26, 2011
Showing with 291 additions and 235 deletions.
  1. +2 −2 bin/carton
  2. +39 −233 lib/Carton.pm
  3. +235 −0 lib/Carton/CLI.pm
  4. +15 −0 lib/Carton/Util.pm
View
@@ -1,6 +1,6 @@
#!perl
use strict;
use 5.008001;
-use Carton;
+use Carton::CLI;
-Carton->new->run(@ARGV);
+Carton::CLI->new->run(@ARGV);
View
@@ -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__
+
Oops, something went wrong.

0 comments on commit 23c50ae

Please sign in to comment.