[carton] 11/472: Implemneted list --tree

[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 84faad2e71b97c971506b2674835c61555f89049
Author: Tatsuhiko Miyagawa <miyagawa at bulknews.net>
Date:   Fri Jun 24 15:15:34 2011 -0700

    Implemneted list --tree
---
 README            |  2 +-
 lib/App/Carton.pm | 92 ++++++++++++++++++++++++++++++++++++++++++++++++++-----
 2 files changed, 85 insertions(+), 9 deletions(-)

diff --git a/README b/README
index 9b138d6..ec0436e 100644
--- a/README
+++ b/README
@@ -8,7 +8,7 @@ SYNOPSIS
       requires 'Plack', 0.9980;
       requires 'Starman', 0.2000;
       ...
-    
+  
       > carton install
       > git commit -m "add Plack and Starman" Makefile.PL carton.json
 
diff --git a/lib/App/Carton.pm b/lib/App/Carton.pm
index c127aa3..a573851 100644
--- a/lib/App/Carton.pm
+++ b/lib/App/Carton.pm
@@ -89,11 +89,12 @@ sub cmd_install {
 
     $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) {
+#    if (@args) {
+#        $self->print("Installing modules from the command line\n");
+#        $self->install_modules(@args);
+#        $self->update_packages;
+#    }
+    if (my $file = $self->has_build_file) {
         $self->print("Installing modules using $file\n");
         $self->install_from_build_file($file);
         $self->update_packages;
@@ -147,10 +148,65 @@ sub install_from_spec {
 sub cmd_show {
     my($self, @args) = @_;
 
+    my $tree_mode;
+    $self->parse_options(\@args, "tree!" => \$tree_mode);
+
     my $data = $self->parse_json('carton.json')
         or $self->error("Can't find carton.json: Run `carton install` to rebuild the spec file.\n");
-    for my $module (values %{$data->{modules} || {}}) {
-        printf "$module->{dist}\n";
+
+    if ($tree_mode) {
+        my $tree = $self->build_tree($data);
+        $self->walk_down($tree, sub {
+            my($module, $depth) = @_;
+            print "  " x $depth;
+            print "$module->{dist}\n";
+        }, 1);
+    } else {
+        for my $module (values %{$data->{modules} || {}}) {
+            printf "$module->{dist}\n";
+        }
+    }
+}
+
+sub build_tree {
+    my($self, $data) = @_;
+
+    my $tree = [];
+    my %cached = ();
+    my @children = keys %{$data->{roots}};
+
+    $self->_build_tree(\@children, $tree, $data->{modules}, \%cached);
+
+    return $tree;
+}
+
+sub _build_tree {
+    my($self, $children, $node, $modules, $cached) = @_;
+    require Module::CoreList;
+    for my $child (@$children) {
+        next if $child eq 'perl' or $cached->{$child}++;
+        if (my $mod = $modules->{$child}) {
+            push @$node, [ $mod, [] ];
+            my %deps = (%{$mod->{requires}{configure}}, %{$mod->{requires}{build}});
+            $self->_build_tree([ keys %deps ], $node->[-1][-1], $modules, $cached);
+        } elsif (!$Module::CoreList::version{$]+0}{$child}) {
+            warn "Can't find $child" if $self->{verbose};
+        }
+    }
+}
+
+sub walk_down {
+    my($self, $tree, $cb, $pre) = @_;
+    $self->_do_walk_down($tree, $cb, 0, $pre);
+}
+
+sub _do_walk_down {
+    my($self, $children, $cb, $depth, $pre) = @_;
+
+    for my $node (@$children) {
+        $cb->($node->[0], $depth) if $pre;
+        $self->_do_walk_down($node->[1], $cb, $depth + 1, $pre);
+        $cb->($node->[0], $depth) unless $pre;
     }
 }
 
@@ -194,14 +250,34 @@ sub parse_json {
     JSON::decode_json(join '', <$fh>);
 }
 
+sub scan_root_deps {
+    my $self = shift;
+
+    my $deps = `$self->{cpanm} --showdeps .`;
+    my %deps;
+    for my $line (split /\n/, $deps) {
+        next unless $line;
+        my($mod, $ver) = split /\s+/, $line, 2;
+        $deps{$mod} = $ver || 0;
+    }
+
+    return %deps;
+}
+
 sub update_packages {
     my $self = shift;
 
     my %locals = $self->find_locals;
+    my %roots  = $self->scan_root_deps;
+
+    my $spec = {
+        modules => \%locals,
+        roots   => \%roots,
+    };
 
     require JSON;
     open my $fh, ">", "carton.json" or die $!;
-    print $fh JSON->new->pretty->encode({ modules => \%locals });
+    print $fh JSON->new->pretty->encode($spec);
 
     return 1;
 }

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