[carton] 16/472: Implemented the tree builder based on dependency tree!
Lucas Kanashiro
kanashiro-guest at moszumanska.debian.org
Fri Jul 24 00:38:27 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 63b5e8c2612549fd429d840fb24e43a1124ebb96
Author: Tatsuhiko Miyagawa <miyagawa at 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
More information about the Pkg-perl-cvs-commits
mailing list