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

_______________________________________________
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

Reply via email to