new THEORY, define inpatch

[topbloke.git] / tb-update.pl

diff --git a/tb-update.pl b/tb-update.pl
index 9cae816c5fcf4430fc7eed7a58d8c9f8afa75b61..58e7d602470c23c11766b39edd1322ba44584694 100755 (executable)
--- a/tb-update.pl
+++ b/tb-update.pl
@@ -14,6 +14,40 @@ die "bad usage\n" if @ARGV;
 check_clean_tree();
 
 
+sub memo ($$$) { 
+    my ($memos,$key,$code) = @_;
+    return $memos->{$key} if exists $memos->{$key};
+    debug("----- $key");
+    $memos->{$key} = $code->();
+}
+
+sub merge_base ($$) {
+    my ($r,$s) = @_; # refs, ideally
+    our %memos;
+    return memo(\%memos, "$r $s", sub {
+       run_git_1line(qw(merge-base), $r, $s);
+               });
+}
+
+sub commit_date ($) {
+    my ($ref) = @_;
+    my $l = run_git_1line(qw(git-log --date=raw -n1 --pretty=format:%cd), $ref);
+    $l =~ m/^(\d+)\s/ or die;
+    return $l;
+}
+
+sub compare_source_ages ($$) {
+    my ($r,$s) = @_; # refs, returns something like  age($r) cmp age($s)
+    our %memos;
+    return memo(\%memos, "$r $s", sub {
+       my $mb = merge_base($r, $s);
+       return -($mb eq $r) cmp ($mb eq $s)
+           # if merge base is $a then $a must be before $b
+           # ie the commit equal to the merge base is earlier
+           or (commit_date($r) cmp commit_date($s));
+    });
+}
+
 sub update_base ($) {
     my ($patch) = @_;
 
@@ -54,7 +88,11 @@ sub update_base ($) {
            } elsif ($depline =~ m/^-/) {
                die "$depline ?"; # should have failed earlier
            } else {
-               push @sources, { Ref => "$tiprefs/$depline", Kind => 'tb' };
+               push @sources, { 
+                   Name => $depline,
+                   Ref => "$tiprefs/$depline", 
+                   Kind => 'topbloke',
+               };
            }
        }
 
@@ -62,7 +100,11 @@ sub update_base ($) {
        if ($obk ne 'missing') {
            $obj eq 'blob' or die "$patch $obk ??";
            chomp $tg or die "$patch ??";
-           push @sources, { Ref => "refs/top-bases/$tg", Kind => 'topgit' };
+           push @sources, {
+               Name => "-topgit $tg",
+               Ref => "refs/top-bases/$tg", 
+               Kind => 'topgit',
+           };
        }
 
        # This bit involves rather too much history walking
@@ -71,27 +113,89 @@ sub update_base ($) {
        # Find the merge base for each source
        foreach my $source (@sources) {
            $source->{Head} = run_git_1line(qw(rev-parse), $source->{Ref});
-           $source->{MergeBase} = 
-               run_git_1line(qw(merge-base), $head, "$baserefs/$patch");
+           $source->{MergeBase} = merge_base($head, "$baserefs/$patch");
        }
        # The merge base is contained in $head, so if it is equal
        # to the source's head, the source is contained in $head -
        # ie we are ahead of the source.  Skip those sources.
        @sources = grep { $source->{MergeBase} ne $source->{Head} } @sources;
 
-       # Now we run git-rev-list to walk the graph back to those
-       # sources so we can tell which is the most recent.
-       foreach my $source (@sources) {
-           
+       if (!@sources) {
+           print "$patch base is up to date\n" or die $!;
+           last;
+       }
 
-    
-           $source->{MergeBase} = $mergebase;
-           
-           bad_metadata("$patch base topgit $obj") unless $obj eq 'blob';
-           
-           # ok
-       } elsif ($obk 
+       my $best = $sources[0];
+       foreach my $source (@sources[1..$#sources]) {
+           next if compare_source_ages($best->{Ref}, $source->{Ref}) <= 0;
+           $best = $source;
+       }
+
+       my $sref = $source->{Ref};
 
+       if ($source->{Kind} eq 'topbloke') {
+           # Check for unwanted dependency removals
+           my (%source_inc,%anc_inc);
+           $source_inc{$_}=1 foreach split /\n/, 
+               git_get_object("$sref:.topbloke/+included");
+           $anc_inc{$_}=1 foreach split /\n/, 
+               git_get_object("$source->{MergeBase}:.topbloke/+included");
+           my @unwanted_dr;
+           foreach my $dep (keys %desired) {
+               next if $source_inc{$dep};
+               unless unless $anc_inc{$dep};
+               my $unw_dr = { Name => $dep };
+
+
+               # Algorithm
+               # We do a history graph walk.
+               # In each iteration we get git-rev-list to find us
+               # one commit.
+
+               # We get git-rev-list to find us 
+ send us a series of commits
+               # We look up each one.
+               my @prune;
+               my $pruned = sub {
+                   my ($commit) = @_;
+                   return grep { commit_has_ancestor($_, $cand) } @prune;
+               };
+               my $prune = sub {
+                   my ($commit) = @_;
+                   return if $pruned->($commit);
+                   push @prune, $commit;
+               };
+               run_git(sub {
+                   my ($cand, @parents) = split;
+                   if (dep_included_in($dep, $cand)) {
+                       $prune->($cand);
+                       return;
+                   }
+                   my @parents_with =
+                       grep { dep_included_in($dep, $_) } @parents;
+                   return if !@parents_with; # irrelevant merge
+                   return if $pruned->($cand); # not interesting any more
+                   $prune->($_) foreach @parents_with;
+                   
+
+                   PROBLEM @prune is bad we want to know why
+                       we have found thing not just whether found
+                   
+                       # 
+                   return if dep_included_in($dep, $cand);
+                   return if 
+                   # OK, it's missing from $cand but included in
+                   # all of $cand's parents.
+                   
+                   },
+                       qw(git-rev-list --date-order --full-history 
+                           --remove-empty)
+                       '--pretty=format:%H %P%n',
+                       $dep, '--', '.topbloke/+included');
+               
+               
+               push @unwanted_dr, { Name => $dep };
+           
 
 sub done ($) { 
     our %done;