This is an automated email from the git hooks/post-receive script. kanashiro-guest pushed a commit to branch master in repository carton.
commit b710d6acf4bd0ab1ce2737176db30788d018c91f Author: Tatsuhiko Miyagawa <[email protected]> Date: Tue Jun 28 00:31:15 2011 -0400 Implemented carton uninstall. Fixes #4 --- lib/Carton.pm | 33 +++++++++++++++++++++++---- lib/Carton/CLI.pm | 67 ++++++++++++++++++++++++++++++++++++++++++++++-------- lib/Carton/Tree.pm | 32 +++++++++++++++++++++----- xt/cli/uninstall.t | 20 ++++++++++++++++ 4 files changed, 132 insertions(+), 20 deletions(-) diff --git a/lib/Carton.pm b/lib/Carton.pm index 8209f96..fdcf74b 100644 --- a/lib/Carton.pm +++ b/lib/Carton.pm @@ -5,7 +5,10 @@ use warnings; use 5.008_001; use version; our $VERSION = qv('v0.1_0'); +use Cwd; +use Config qw(%Config); use Carton::Util; +use File::Path; sub new { my $class = shift; @@ -187,7 +190,7 @@ sub walk_down_tree { } sub build_tree { - my($self, $modules) = @_; + my($self, $modules, %args) = @_; my $idx = $self->build_index($modules); my $pool = { %$modules }; # copy @@ -198,7 +201,8 @@ sub build_tree { $self->_build_tree($pick, $tree, $tree, $pool, $idx); } - $tree->finalize; + $tree->finalize + unless $args{no_finalize}; return $tree; } @@ -301,9 +305,6 @@ sub find_locals { sub check_satisfies { my($self, $lock, $deps) = @_; - # TODO recurse dep tree to see all your dependencies are satisfied - # TODO then check if something is remaining in $lock, which is not specified in the build file - my @unsatisfied; my $index = $self->build_index($lock->{modules}); my %pool = %{$lock->{modules}}; # copy @@ -352,5 +353,27 @@ sub _check_satisfies { } } +sub uninstall { + my($self, $lock, $module) = @_; + + my $meta = $lock->{modules}{$module}; + (my $path_name = $meta->{name}) =~ s!::!/!g; + + my $path = Cwd::realpath($self->{path}); + my $packlist = "$path/lib/perl5/$Config{archname}/auto/$path_name/.packlist"; + + open my $fh, "<", $packlist or die "Couldn't locate .packlist for $meta->{name}"; + while (<$fh>) { + # EUMM merges with site and perl library paths + chomp; + next unless /^\Q$path\E/; + unlink $_ or warn "Couldn't unlink $_: $!"; + } + + unlink $packlist; + if ($meta->{dist}) { # safety guard not to rm -r auto/meta + File::Path::rmtree("$self->{path}/lib/perl5/auto/meta/$meta->{dist}"); + } +} 1; diff --git a/lib/Carton/CLI.pm b/lib/Carton/CLI.pm index c5f3ece..902c141 100644 --- a/lib/Carton/CLI.pm +++ b/lib/Carton/CLI.pm @@ -150,6 +150,54 @@ sub cmd_install { $self->print("Complete! Modules were installed into $self->{path}\n", SUCCESS); } +sub cmd_uninstall { + my($self, @args) = @_; + + $self->parse_options(\@args, "p|path=s", \$self->{path}); + $self->carton->configure( + path => $self->{path}, + ); + + my $lock = $self->find_lock + or $self->error("Can't find carton.lock: Run `carton install`"); + + my $index = $self->carton->build_index($lock->{modules}); + + my @meta; + for my $module (@args) { + if (exists $index->{$module}) { + push @meta, $index->{$module}{meta}; + } else { + $self->print("Can't locate module $module\n", WARN); + } + } + + # only can uninstall root dependencies + my $tree = $self->carton->build_tree($lock->{modules}, no_finalize => 1); + for my $root ($tree->children) { + if (grep $_->{name} eq $root->key, @meta) { + $tree->remove_child($root); + } + } + $tree->finalize; + + my @missing = grep !$tree->has_child($_), keys %{$lock->{modules}}; + for my $module (@missing) { + my $meta = $lock->{modules}{$module}; + $self->print("Uninstalling $meta->{dist}\n"); + $self->carton->uninstall($lock, $module); + } + + for my $meta (@meta) { + unless (grep $meta->{name} eq $_, @missing) { + $self->print("$meta->{name} is dependent by some other modules. Can't uninstall it.\n", WARN); + } + } + + $self->carton->update_lock_file($self->lock_file); + $self->print("Complete! Modules and its dependencies were uninstalled from $self->{path}\n", SUCCESS); +} + sub mirror_file { my $self = shift; return $self->work_file("02packages.details.txt"); @@ -164,16 +212,19 @@ sub has_build_file { return $file; } -*cmd_list = \&cmd_show; +sub cmd_tree { + my $self = shift; + $self->cmd_list("--tree", @_); +} -sub cmd_show { +sub cmd_list { 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"); + my $lock = $self->find_lock + or $self->error("Can't find carton.lock: Run `carton install` to rebuild the lock file.\n"); if ($tree_mode) { my $tree = $self->carton->build_tree($lock->{modules}); @@ -251,11 +302,9 @@ sub find_lock { sub lock_data { my $self = shift; - return $self->{lock} if $self->{lock}; - + my $lock; try { - my $lock = Carton::Util::parse_json($self->lock_file); - $self->{lock} = $lock; + $lock = Carton::Util::parse_json($self->lock_file); } catch { if (/No such file/) { $self->error("Can't locate carton.lock\n"); @@ -264,7 +313,7 @@ sub lock_data { } }; - return $self->{lock}; + return $lock; } sub lock_file { diff --git a/lib/Carton/Tree.pm b/lib/Carton/Tree.pm index 56140ab..7a4e25d 100644 --- a/lib/Carton/Tree.pm +++ b/lib/Carton/Tree.pm @@ -20,15 +20,17 @@ sub new { return $self; } -sub walk_down { - my($self, $cb) = @_; - - $cb ||= sub { +sub dump { + my $self = shift; + $self->walk_down(sub { my($node, $depth) = @_; print " " x $depth; print $node->key, "\n"; - }; + }); +} +sub walk_down { + my($self, $cb) = @_; $self->_walk_down($cb, undef, 0); } @@ -78,7 +80,11 @@ sub remove_child { my @new; for my $child (@{$self->[2]}) { - push @new, $child if $rm->key ne $child->key; + if ($rm->key eq $child->key) { + undef $child; + } else { + push @new, $child; + } } $self->[2] = \@new; @@ -129,4 +135,18 @@ sub finalize { %cache = (); } +sub has_child { + my($self, $key) = @_; + + my $has; + $self->walk_down(sub { + if ($_[0]->key eq $key) { + $has++; + return $self->abort; + } + }); + + return $has; +} + 1; diff --git a/xt/cli/uninstall.t b/xt/cli/uninstall.t new file mode 100644 index 0000000..f3d3ca1 --- /dev/null +++ b/xt/cli/uninstall.t @@ -0,0 +1,20 @@ +use strict; +use Test::More; +use xt::CLI; + +{ + my $app = cli(); + + $app->run("install", "Try::Tiny"); + $app->run("list"); + like $app->output, qr/Try-Tiny-/; + + $app->run("uninstall", "Try::Tiny"); + like $app->output, qr/Uninstalling Try-Tiny-/; + + $app->run("list"); + like $app->output, qr/^\s*$/s; +} + +done_testing; + -- 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 [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
