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