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                 my @prune;
 149                 my $pruned = sub {
 150                     my ($commit) = @_;
 151                     return grep { commit_has_ancestor($_, $cand) } @prune;
 152                 };
 153                 my $prune = sub {
 154                     my ($commit) = @_;
 155                     return if $pruned->($commit);
 156                     push @prune, $commit;
 157                 };
 158                 run_git(sub {
 159                     my ($cand, @parents) = split;
 160                     if (dep_included_in($dep, $cand)) {
 161                         $prune->($cand);
 162                         return;
 163                     }
 164                     my @parents_with =
 165                         grep { dep_included_in($dep, $_) } @parents;
 166                     return if !@parents_with; # irrelevant merge
 167                     return if $pruned->($cand); # not interesting any more
 168                     $prune->($_) foreach @parents_with;
 169
 170
 171                     PROBLEM @prune is bad we want to know why
 172                         we have found thing not just whether found
 173
 174                         #
 175                     return if dep_included_in($dep, $cand);
 176                     return if
 177                     # OK, it's missing from $cand but included in
 178                     # all of $cand's parents.
 179
 180                     },
 181                         qw(git-rev-list --date-order --full-history
 182                            --remove-empty)
 183                         '--pretty=format:%H %P%n',
 184                         $dep, '--', '.topbloke/+included');
 185
 186
 187                 push @unwanted_dr, { Name => $dep };
 188
 189
 190 sub done ($) {
 191     our %done;
 192     return 1 if $done{$_[0]}++;
 193     debug("----- $key");
 194 }
 195
 196 sub memo ($$) {
 197     my ($key,$code) = @_;
 198     our %memo;
 199     return $memo{$key} if exists $memo{$key};
 200     debug("----- $key");
 201     $memo{$key} = $code->();
 202 }
 203
 204 sub tip_sources_core
 205
 206 sub tip_sources ($) {
 207     my ($patch) = @_;
 208     my @sources = ();
 209     push @sources, { How => 'base', Ref => "$baserefs/$patch" };
 210     foreach my $remote (get_configured_remotes()) {
 211         push @sources, { How => 'remote',
 212                          Ref => "refs/remotes/$remote/topbloke-tips/$patch" };
 213     }
 214
 215 sub compute_desired_deps ($) {
 216     my ($patch) = @_;
 217  return memo("compute_desired_deps $patch", {
 218      foreach my $sourceref (tip_source_refs($patch)) {
 219          die...
 220  });
 221 }
 222
 223 sub update_base ($) {
 224     my ($patch) = @_;
 225     return if done("update_base $patch");
 226     my @desired_deps = compute_desired_deps($patch);
 227     die...
 228
 229 sub update_deps ($) {
 230     my $patch = @_;
 231     return if done("update_deps $patch");
 232     my $deps = git_get_object("$baserefs/$patch:.topbloke/deps");
 233     foreach my $dep (split /\n/, $deps) {
 234         if ($dep =~ m/^tb /) {
 235             my $dep_patch = $'; #';
 236             update_patch($dep_patch);
 237         }
 238     }
 239 }
 240
 241 sub update_patch ($) {
 242     my $patch = @_;
 243     update_deps($patch);
 244     update_base($patch);
 245     update_tip($patch);
 246 }
 247
 248 our $current = current_branch();
 249 if ($current->{Kind} eq 'tip') {
 250     update_patch($current);
 251 } elsif ($current->{Kind} eq 'base') {
 252     update_deps($current);
 253     update_base($current);
 254 } else {
 255     die "Not a topbloke branch ($current->{Kind})\n";
 256 }