[carton] 11/472: Implemneted list --tree
Lucas Kanashiro
kanashiro-guest at moszumanska.debian.org
Fri Jul 24 00:38:26 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 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
More information about the Pkg-perl-cvs-commits
mailing list