Skip to content
Browse files

Preserve original plan order when dependencies allow it.

The original
[`tsort`](http://alumnus.caltech.edu/~copeland/work/tsort.html)-derived
algorithm did not attempt to preseve the original order of the list of
changes. My thanks to @user5402 for providing the solution to fix this issue
in [this SO answer](http://stackoverflow.com/a/13370233/79202). As a
side-effect, a couple of other tests that had been listing changes in the
order they are specified as dependencies now preserve the original order
there, too.
  • Loading branch information...
1 parent 2de526d commit 86b66b048c52326d991bc81e631460ad37228041 @theory committed Nov 13, 2012
Showing with 22 additions and 18 deletions.
  1. +20 −16 lib/App/Sqitch/Plan.pm
  2. +2 −2 t/plan.t
View
36 lib/App/Sqitch/Plan.pm
@@ -455,13 +455,17 @@ sub sort_changes {
my %pairs; # all pairs ($l, $r)
my %nreqs; # number of requiring changes
my %deps; # list of dependencies
+ my %order; # tracks orinal order of the objects.
+
+ my $i = 0;
for my $change (@_) {
# Stolen from http://cpansearch.perl.org/src/CWEST/ppt-0.14/bin/tsort.
my $name = $change->name;
$obj{$name} = $change;
my $p = $pairs{$name} = {};
$nreqs{$name} += 0;
+ $order{$name} //= $i++;
# XXX Ignoring conflicts for now.
for my $dep ( $change->requires ) {
@@ -494,27 +498,27 @@ sub sort_changes {
}
}
- # Stolen from http://cpansearch.perl.org/src/CWEST/ppt-0.14/bin/tsort.
- # Create a list of changes without predecessors
- my @list = grep { !$nreqs{$_->name} } @_;
-
+ # Sort for dependencies, preferring original order.
+ # http://stackoverflow.com/a/13370233/79202
my @ret;
- while (@list) {
- my $change = pop @list;
- unshift @ret => $change;
- foreach my $child ( @{ $deps{$change->name} } ) {
- unless ( $pairs{$child} ) {
- hurl plan => __x(
- 'Unknown change "{required}" required by change "{change}"',
- required => $child,
- change => $change->name,
- );
+ while (my @list = grep { !$nreqs{$_} } keys %nreqs) {
+ unshift @ret => map { $obj{$_} } sort { $order{$a} <=> $order{$b} } @list;
+ for my $name (@list) {
+ delete $nreqs{$name};
+ for my $child ( @{ $deps{$name} } ) {
+ unless ( $pairs{$child} ) {
+ hurl plan => __x(
+ 'Unknown change "{required}" required by change "{change}"',
+ required => $child,
+ change => $name,
+ );
+ }
+ $nreqs{$child}--;
}
- push @list, $obj{$child} unless --$nreqs{$child};
}
}
- if ( my @cycles = map { $_->name } grep { $nreqs{$_->name} } @_ ) {
+ if ( my @cycles = sort { $order{$a} <=> $order{$b} } keys %nreqs ) {
my $last = pop @cycles;
hurl plan => __x(
'Dependency cycle detected between changes {changes}',
View
4 t/plan.t
@@ -1492,7 +1492,7 @@ cmp_deeply [$plan->sort_changes('foo', changes qw(this that other))],
# Have this require other and that.
@deps = ({%ddep, requires => [dep 'other', dep 'that']}, {%ddep}, {%ddep});
cmp_deeply [$plan->sort_changes('foo', changes qw(this that other))],
- [changes qw(other that this)], 'Should get other, that, this now';
+ [changes qw(that other this)], 'Should get that, other, this now';
# Have this require other and that, and other requore that.
@deps = ({%ddep, requires => [dep 'other', dep 'that']}, {%ddep}, {%ddep, requires => [dep 'that']});
@@ -1556,7 +1556,7 @@ cmp_deeply [$plan->sort_changes('foo', { foo => 1}, changes qw(this that other))
# Mix it up.
@deps = ({%ddep, requires => [dep 'other', dep 'that']}, {%ddep, requires => [dep 'sqitch']}, {%ddep});
cmp_deeply [$plan->sort_changes('foo', {sqitch => 1 }, changes qw(this that other))],
- [changes qw(other that this)], 'Should get other, that, this with earlier dependncy';
+ [changes qw(that other this)], 'Should get that, other, this with earlier dependncy';
# Make sure it fails on unknown previous dependencies.
@deps = ({%ddep, requires => [dep 'foo']}, {%ddep}, {%ddep});

0 comments on commit 86b66b0

Please sign in to comment.
Something went wrong with that request. Please try again.