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