[carton] 65/472: Implemented carton uninstall. Fixes #4
Lucas Kanashiro
kanashiro-guest at moszumanska.debian.org
Fri Jul 24 00:38:33 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 b710d6acf4bd0ab1ce2737176db30788d018c91f
Author: Tatsuhiko Miyagawa <miyagawa at bulknews.net>
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
More information about the Pkg-perl-cvs-commits
mailing list