chiark / gitweb /
new THEORY, define inpatch
[topbloke.git] / tb-update.pl
1 #!/usr/bin/perl
2 # usage: tb-update [options]
3
4 use warnings;
5 use strict;
6
7 use Getopt::Long;
8 use Topbloke;
9
10 Getopt::Long::Configure(qw(bundling));
11
12 die "bad usage\n" if @ARGV;
13
14 check_clean_tree();
15
16
17 sub memo ($$$) { 
18     my ($memos,$key,$code) = @_;
19     return $memos->{$key} if exists $memos->{$key};
20     debug("----- $key");
21     $memos->{$key} = $code->();
22 }
23
24 sub merge_base ($$) {
25     my ($r,$s) = @_; # refs, ideally
26     our %memos;
27     return memo(\%memos, "$r $s", sub {
28         run_git_1line(qw(merge-base), $r, $s);
29                 });
30 }
31
32 sub commit_date ($) {
33     my ($ref) = @_;
34     my $l = run_git_1line(qw(git-log --date=raw -n1 --pretty=format:%cd), $ref);
35     $l =~ m/^(\d+)\s/ or die;
36     return $l;
37 }
38
39 sub compare_source_ages ($$) {
40     my ($r,$s) = @_; # refs, returns something like  age($r) cmp age($s)
41     our %memos;
42     return memo(\%memos, "$r $s", sub {
43         my $mb = merge_base($r, $s);
44         return -($mb eq $r) cmp ($mb eq $s)
45             # if merge base is $a then $a must be before $b
46             # ie the commit equal to the merge base is earlier
47             or (commit_date($r) cmp commit_date($s));
48     });
49 }
50
51 sub update_base ($) {
52     my ($patch) = @_;
53
54     for (;;) {
55         check_baseref_metadata("$baserefs/$patch");
56
57         my $head = git_run_1line(qw(rev-parse),"$baserefs/$patch");
58
59         # 2.i. Compute set of desired included deps
60         my %desired;
61         my $add_desired = sub {
62             my ($sub) = @_;
63             my ($obk,$deps) = git_get_object("$baserefs/$sub:.topbloke/deps");
64             die "$sub $obk ??" unless $obk eq 'blob';
65             foreach my $depline (split /\n/, $deps) {
66                 next if exists $desired{$depline};
67                 $desired{$depline} = 1;
68                 if ($depline =~ m/^- /) {
69                 } elsif ($depline =~ m/^-/) {
70                     die "$depline ?";
71                 } else {
72                     check_baseref_metadata("$baserefs/$depline");
73                     $add_desired->($depline);
74                 }
75             }
76         };
77         $add_desired->($patch);
78
79         # 2.ii. do the merges
80         # first, find the list of sources
81
82         my @sources;
83         my ($obk,$deps) = git_get_object("$baserefs/$patch:.topbloke/deps");
84         die "$patch $obk ??" unless $obk eq 'blob';
85         foreach my $depline (split /\n/, $deps) {
86             if ($depline =~ m/^- /) {
87                 push @sources, { Ref => "$'", Kind => 'foreign' };
88             } elsif ($depline =~ m/^-/) {
89                 die "$depline ?"; # should have failed earlier
90             } else {
91                 push @sources, { 
92                     Name => $depline,
93                     Ref => "$tiprefs/$depline", 
94                     Kind => 'topbloke',
95                 };
96             }
97         }
98
99         my ($obk,$tg) = git_get_object("$baserefs/$patch:.topbloke/topgit-");
100         if ($obk ne 'missing') {
101             $obj eq 'blob' or die "$patch $obk ??";
102             chomp $tg or die "$patch ??";
103             push @sources, {
104                 Name => "-topgit $tg",
105                 Ref => "refs/top-bases/$tg", 
106                 Kind => 'topgit',
107             };
108         }
109
110         # This bit involves rather too much history walking
111         # and could perhaps be optimised.
112
113         # Find the merge base for each source
114         foreach my $source (@sources) {
115             $source->{Head} = run_git_1line(qw(rev-parse), $source->{Ref});
116             $source->{MergeBase} = merge_base($head, "$baserefs/$patch");
117         }
118         # The merge base is contained in $head, so if it is equal
119         # to the source's head, the source is contained in $head -
120         # ie we are ahead of the source.  Skip those sources.
121         @sources = grep { $source->{MergeBase} ne $source->{Head} } @sources;
122
123         if (!@sources) {
124             print "$patch base is up to date\n" or die $!;
125             last;
126         }
127
128         my $best = $sources[0];
129         foreach my $source (@sources[1..$#sources]) {
130             next if compare_source_ages($best->{Ref}, $source->{Ref}) <= 0;
131             $best = $source;
132         }
133
134         my $sref = $source->{Ref};
135
136         if ($source->{Kind} eq 'topbloke') {
137             # Check for unwanted dependency removals
138             my (%source_inc,%anc_inc);
139             $source_inc{$_}=1 foreach split /\n/, 
140                 git_get_object("$sref:.topbloke/+included");
141             $anc_inc{$_}=1 foreach split /\n/, 
142                 git_get_object("$source->{MergeBase}:.topbloke/+included");
143             my @unwanted_dr;
144             foreach my $dep (keys %desired) {
145                 next if $source_inc{$dep};
146                 unless unless $anc_inc{$dep};
147                 my $unw_dr = { Name => $dep };
148
149
150                 # Algorithm
151                 # We do a history graph walk.
152                 # In each iteration we get git-rev-list to find us
153                 # one commit.
154
155                 # We get git-rev-list to find us 
156  send us a series of commits
157                 # We look up each one.
158                 my @prune;
159                 my $pruned = sub {
160                     my ($commit) = @_;
161                     return grep { commit_has_ancestor($_, $cand) } @prune;
162                 };
163                 my $prune = sub {
164                     my ($commit) = @_;
165                     return if $pruned->($commit);
166                     push @prune, $commit;
167                 };
168                 run_git(sub {
169                     my ($cand, @parents) = split;
170                     if (dep_included_in($dep, $cand)) {
171                         $prune->($cand);
172                         return;
173                     }
174                     my @parents_with =
175                         grep { dep_included_in($dep, $_) } @parents;
176                     return if !@parents_with; # irrelevant merge
177                     return if $pruned->($cand); # not interesting any more
178                     $prune->($_) foreach @parents_with;
179                     
180
181                     PROBLEM @prune is bad we want to know why
182                         we have found thing not just whether found
183                     
184                         # 
185                     return if dep_included_in($dep, $cand);
186                     return if 
187                     # OK, it's missing from $cand but included in
188                     # all of $cand's parents.
189                     
190                     },
191                         qw(git-rev-list --date-order --full-history 
192                            --remove-empty)
193                         '--pretty=format:%H %P%n',
194                         $dep, '--', '.topbloke/+included');
195                 
196                 
197                 push @unwanted_dr, { Name => $dep };
198             
199
200 sub done ($) { 
201     our %done; 
202     return 1 if $done{$_[0]}++;
203     debug("----- $key");
204 }
205
206 sub memo ($$) { 
207     my ($key,$code) = @_;
208     our %memo;
209     return $memo{$key} if exists $memo{$key};
210     debug("----- $key");
211     $memo{$key} = $code->();
212 }
213
214 sub tip_sources_core
215
216 sub tip_sources ($) {
217     my ($patch) = @_;
218     my @sources = ();
219     push @sources, { How => 'base', Ref => "$baserefs/$patch" };
220     foreach my $remote (get_configured_remotes()) {
221         push @sources, { How => 'remote', 
222                          Ref => "refs/remotes/$remote/topbloke-tips/$patch" };
223     }
224
225 sub compute_desired_deps ($) {
226     my ($patch) = @_;
227  return memo("compute_desired_deps $patch", {
228      foreach my $sourceref (tip_source_refs($patch)) {
229          die...
230  });
231 }
232
233 sub update_base ($) {
234     my ($patch) = @_;
235     return if done("update_base $patch");
236     my @desired_deps = compute_desired_deps($patch);
237     die...
238
239 sub update_deps ($) {
240     my $patch = @_;
241     return if done("update_deps $patch");
242     my $deps = git_get_object("$baserefs/$patch:.topbloke/deps");
243     foreach my $dep (split /\n/, $deps) {
244         if ($dep =~ m/^tb /) {
245             my $dep_patch = $'; #';
246             update_patch($dep_patch);
247         }
248     }
249 }
250
251 sub update_patch ($) {
252     my $patch = @_;
253     update_deps($patch);
254     update_base($patch);
255     update_tip($patch);
256 }
257
258 our $current = current_branch();
259 if ($current->{Kind} eq 'tip') {
260     update_patch($current);
261 } elsif ($current->{Kind} eq 'base') {
262     update_deps($current);
263     update_base($current);
264 } else {
265     die "Not a topbloke branch ($current->{Kind})\n";
266 }