[carton] 85/472: Uninstalling modules should not remove dependencies in Makefile.PL. Fixes #16

[Lucas Kanashiro]

This is an automated email from the git hooks/post-receive script.

kanashiro-guest pushed a commit to branch master
in repository carton.

commit 0673a8bba69086704f5490e2d3ef9ffa0601ff88
Author: Tatsuhiko Miyagawa <miyagawa at bulknews.net>
Date:   Wed Jun 29 23:33:33 2011 -0400

    Uninstalling modules should not remove dependencies in Makefile.PL. Fixes #16
    
    In $tree->normalize, check if the sub-tree of the element is actually
    specified as a direct dependency in Makefile.PL, in which case,
    restore the link to the sub-tree in the root child elements.
---
 lib/Carton.pm      |  4 ++--
 lib/Carton/CLI.pm  | 14 ++++++++++++--
 lib/Carton/Tree.pm | 17 ++++++++++++++---
 3 files changed, 28 insertions(+), 7 deletions(-)

diff --git a/lib/Carton.pm b/lib/Carton.pm
index d483cf9..f09a1f6 100644
--- a/lib/Carton.pm
+++ b/lib/Carton.pm
@@ -203,7 +203,7 @@ sub walk_down_tree {
 }
 
 sub build_tree {
-    my($self, $modules) = @_;
+    my($self, $modules, $root) = @_;
 
     my $idx  = $self->build_index($modules);
     my $pool = { %$modules }; # copy
@@ -214,7 +214,7 @@ sub build_tree {
         $self->_build_tree($pick, $tree, $tree, $pool, $idx);
     }
 
-    $tree->finalize;
+    $tree->finalize($root);
 
     return $tree;
 }
diff --git a/lib/Carton/CLI.pm b/lib/Carton/CLI.pm
index bca6ecc..87062a3 100644
--- a/lib/Carton/CLI.pm
+++ b/lib/Carton/CLI.pm
@@ -195,15 +195,25 @@ sub cmd_uninstall {
         }
     }
 
+    my %root;
+    if ($self->has_build_file) {
+        for my $dep ($self->carton->list_dependencies) {
+            my($mod, $ver) = split /~/, $dep;
+            if (exists $index->{$mod}) {
+                $root{ $index->{$mod}{meta}{name} } = 1;
+            }
+        }
+    }
+
     # only can uninstall root dependencies
-    my $tree = $self->carton->build_tree($lock->{modules});
+    my $tree = $self->carton->build_tree($lock->{modules}, \%root);
     for my $root ($tree->children) {
         if (grep $_->{name} eq $root->key, @meta) {
             $tree->remove_child($root);
         }
     }
 
-    my @missing = grep !$tree->has_child($_), keys %{$lock->{modules}};
+    my @missing = grep !$tree->find_child($_), keys %{$lock->{modules}};
     for my $module (@missing) {
         my $meta = $lock->{modules}{$module};
         $self->print("Uninstalling $meta->{dist}\n");
diff --git a/lib/Carton/Tree.pm b/lib/Carton/Tree.pm
index ebd0fe6..7454b08 100644
--- a/lib/Carton/Tree.pm
+++ b/lib/Carton/Tree.pm
@@ -103,7 +103,9 @@ sub new {
 }
 
 sub finalize {
-    my $self = shift;
+    my($self, $want_root) = @_;
+
+    $want_root ||= {};
 
     my %subtree;
     my @ancestor;
@@ -125,17 +127,26 @@ sub finalize {
     my $up = sub { pop @ancestor };
     $self->_walk_down($down, $up, 0);
 
-    # remove root nodes that are sub-tree of another
+    # normalize: remove root nodes that are sub-tree of another
     for my $child ($self->children) {
         if ($subtree{$child->key}) {
             $self->remove_child($child);
         }
     }
 
+    # Ugh, but if the build file is there, restore the links to sub-tree as a root elements
+    my %curr_root = map { ($_->key => 1) } $self->children;
+    for my $key (keys %$want_root) {
+        my $node = $self->find_child($key) or next;
+        unless ($curr_root{$node->key}) {
+            $self->add_child($node);
+        }
+    }
+
     %cache = ();
 }
 
-sub has_child {
+sub find_child {
     my($self, $key) = @_;
 
     my $child;

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/carton.git