This is an automated email from the git hooks/post-receive script. kanashiro-guest pushed a commit to branch master in repository carton.
commit 63b5e8c2612549fd429d840fb24e43a1124ebb96 Author: Tatsuhiko Miyagawa <miyag...@bulknews.net> Date: Sat Jun 25 19:49:57 2011 -0700 Implemented the tree builder based on dependency tree! --- lib/App/Carton.pm | 111 +++++++++++++++++++++---------------------- lib/App/Carton/Tree.pm | 125 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 181 insertions(+), 55 deletions(-) diff --git a/lib/App/Carton.pm b/lib/App/Carton.pm index 0a0c268..251d389 100644 --- a/lib/App/Carton.pm +++ b/lib/App/Carton.pm @@ -8,6 +8,8 @@ use Config; use Getopt::Long; use Term::ANSIColor qw(colored); +use App::Carton::Tree; + our $Colors = { SUCCESS => 'green', INFO => 'cyan', @@ -150,6 +152,8 @@ sub install_from_spec { sub cmd_show { my($self, @args) = @_; + require Module::CoreList; + my $tree_mode; $self->parse_options(\@args, "tree!" => \$tree_mode); @@ -157,12 +161,20 @@ sub cmd_show { or $self->error("Can't find carton.json: Run `carton install` to rebuild the spec file.\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); + my %seen; + my $tree = $self->build_tree($data->{modules}); + $tree->walk_down(sub { + my($node, $depth, $parent) = @_; + + return $tree->abort if $seen{$node->key}++; + + if ($node->metadata->{dist}) { + print " " x $depth; + print $node->metadata->{dist}, "\n"; + } elsif (!$Module::CoreList::version{$]+0}{$node->key}) { + warn "Couldn't find ", $node->key, "\n"; + } + }); } else { for my $module (values %{$data->{modules} || {}}) { printf "$module->{dist}\n"; @@ -176,10 +188,10 @@ sub build_index { my $index; for my $name (keys %$modules) { - my $module = $modules->{$name}; - my $provides = $module->{provides}; + my $metadata = $modules->{$name}; + my $provides = $metadata->{provides}; for my $mod (keys %$provides) { - $index->{$mod} = { version => $provides->{$mod}, module => $module }; + $index->{$mod} = { version => $provides->{$mod}, meta => $metadata }; } } @@ -187,49 +199,54 @@ sub build_index { } sub build_tree { - my($self, $data) = @_; + my($self, $modules) = @_; + + my $idx = $self->build_index($modules); + my $pool = { %$modules }; # copy - my $tree = []; - my %cached = (); - my @children = keys %{$data->{roots}}; + my $tree = App::Carton::Tree->new; - my $index = $self->build_index($data->{modules}); + while (my $pick = (keys %$pool)[0]) { + $self->_build_tree($pick, $tree, $tree, $pool, $idx); + } - $self->_build_tree(\@children, $tree, $index, \%cached); + $tree->finalize; return $tree; } sub _build_tree { - my($self, $children, $node, $index, $cached) = @_; - require Module::CoreList; - for my $child (@$children) { - next if $child eq 'perl'; - if (my $mod = $index->{$child}) { - $mod = $mod->{module}; - next if $cached->{$mod->{name}}++; - push @$node, [ $mod, [] ]; - my %deps = (%{$mod->{requires}{configure}}, %{$mod->{requires}{build}}); - $self->_build_tree([ keys %deps ], $node->[-1][-1], $index, $cached); - } elsif (!$Module::CoreList::version{$]+0}{$child}) { - warn "Can't find $child\n"; - } + my($self, $elem, $tree, $curr_node, $pool, $idx) = @_; + + if (my $cached = App::Carton::TreeNode->cached($elem)) { + $curr_node->add_child($cached); + return; } -} -sub walk_down { - my($self, $tree, $cb, $pre) = @_; - $self->_do_walk_down($tree, $cb, 0, $pre); -} + my $node = App::Carton::TreeNode->new($elem, $pool); + $curr_node->add_child($node); -sub _do_walk_down { - my($self, $children, $cb, $depth, $pre) = @_; + for my $child ( $self->build_deps($node->metadata, $idx) ) { + $self->_build_tree($child, $tree, $node, $pool, $idx); + } +} - 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; +sub build_deps { + my($self, $meta, $idx) = @_; + + my @deps; + for my $requires (values %{$meta->{requires}}) { + for my $module (keys %$requires) { + next if $module eq 'perl'; + if (exists $idx->{$module}) { + push @deps, $idx->{$module}{meta}{name}; + } else { + push @deps, $module; + } + } } + + return @deps; } sub cmd_check { @@ -272,29 +289,13 @@ 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; diff --git a/lib/App/Carton/Tree.pm b/lib/App/Carton/Tree.pm new file mode 100644 index 0000000..03bac7b --- /dev/null +++ b/lib/App/Carton/Tree.pm @@ -0,0 +1,125 @@ +package App::Carton::TreeNode; +use strict; +use warnings; + +my %cache; + +sub cached { + my($class, $key) = @_; + return $cache{$key}; +} + +sub new { + my($class, $key, $pool) = @_; + + my $meta = delete $pool->{$key} || {}; + + my $self = bless [ $key, $meta, [] ], $class; + $cache{$key} = $self; + + return $self; +} + +sub walk_down { + my($self, $cb) = @_; + + $cb ||= sub { + my($node, $depth) = @_; + print " " x $depth; + print $node->key, "\n"; + }; + + $self->_walk_down($cb, undef, 0); +} + +sub _walk_down { + my($self, $pre_cb, $post_cb, $depth) = @_; + + my @child = $self->children; + for my $child ($self->children) { + local $App::Carton::Tree::Abort = 0; + if ($pre_cb) { + $pre_cb->($child, $depth, $self); + } + + unless ($App::Carton::Tree::Abort) { + $child->_walk_down($pre_cb, $post_cb, $depth + 1); + } + + if ($post_cb) { + $post_cb->($child, $depth, $self); + } + } +} + +sub abort { + $App::Carton::Tree::Abort = 1; +} + +sub key { $_[0]->[0] } +sub metadata { $_[0]->[1] } + +sub children { @{$_[0]->[2]} } + +sub add_child { + my $self = shift; + push @{$self->[2]}, @_; +} + +sub remove_child { + my($self, $rm) = @_; + + my @new; + for my $child (@{$self->[2]}) { + push @new, $child if $rm->key ne $child->key; + } + + $self->[2] = \@new; +} + +sub is { + my($self, $node) = @_; + $self->key eq $node->key; +} + +package App::Carton::Tree; +our @ISA = qw(App::Carton::TreeNode); + +sub new { + bless [0, {}, []], shift; +} + +sub finalize { + my $self = shift; + + my %subtree; + my @ancestor; + + my $down = sub { + my($node, $depth, $parent) = @_; + + if (grep $node->is($_), @ancestor) { + $parent->remove_child($node); + return $self->abort; + } + + $subtree{$node->key} = 1 if $depth > 0; + + push @ancestor, $node; + return 1; + }; + + my $up = sub { pop @ancestor }; + $self->_walk_down($down, $up, 0); + + # remove root nodes that are sub-tree of another + for my $child ($self->children) { + if ($subtree{$child->key}) { + $self->remove_child($child); + } + } + + %cache = (); +} + +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