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 committ_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 update_base ($) {
  40     my ($patch) = @_;
  41
  42     for (;;) {
  43         check_baseref_metadata("$baserefs/$patch");
  44
  45         my $head = git_run_1line(qw(rev-parse),"$baserefs/$patch");
  46
  47         # 2.i. Compute set of desired included deps
  48         my %desired;
  49         my $add_desired = sub {
  50             my ($sub) = @_;
  51             my ($obk,$deps) = git_get_object("$baserefs/$sub:.topbloke/deps");
  52             die "$sub $obk ??" unless $obk eq 'blob';
  53             foreach my $depline (split /\n/, $deps) {
  54                 next if exists $desired{$depline};
  55                 $desired{$depline} = 1;
  56                 if ($depline =~ m/^- /) {
  57                 } elsif ($depline =~ m/^-/) {
  58                     die "$depline ?";
  59                 } else {
  60                     check_baseref_metadata("$baserefs/$depline");
  61                     $add_desired->($depline);
  62                 }
  63             }
  64         };
  65         $add_desired->($patch);
  66
  67         # 2.ii. do the merges
  68         # first, find the list of sources
  69
  70         my @sources;
  71         my ($obk,$deps) = git_get_object("$baserefs/$patch:.topbloke/deps");
  72         die "$patch $obk ??" unless $obk eq 'blob';
  73         foreach my $depline (split /\n/, $deps) {
  74             if ($depline =~ m/^- /) {
  75                 push @sources, { Ref => "$'", Kind => 'foreign' };
  76             } elsif ($depline =~ m/^-/) {
  77                 die "$depline ?"; # should have failed earlier
  78             } else {
  79                 push @sources, {
  80                     Name => $depline,
  81                     Ref => "$tiprefs/$depline",
  82                     Kind => 'tb',
  83                 };
  84             }
  85         }
  86
  87         my ($obk,$tg) = git_get_object("$baserefs/$patch:.topbloke/topgit-");
  88         if ($obk ne 'missing') {
  89             $obj eq 'blob' or die "$patch $obk ??";
  90             chomp $tg or die "$patch ??";
  91             push @sources, {
  92                 Name => "-topgit $tg",
  93                 Ref => "refs/top-bases/$tg",
  94                 Kind => 'topgit',
  95             };
  96         }
  97
  98         # This bit involves rather too much history walking
  99         # and could perhaps be optimised.
 100
 101         # Find the merge base for each source
 102         foreach my $source (@sources) {
 103             $source->{Head} = run_git_1line(qw(rev-parse), $source->{Ref});
 104             $source->{MergeBase} = merge_base($head, "$baserefs/$patch");
 105         }
 106         # The merge base is contained in $head, so if it is equal
 107         # to the source's head, the source is contained in $head -
 108         # ie we are ahead of the source.  Skip those sources.
 109         @sources = grep { $source->{MergeBase} ne $source->{Head} } @sources;
 110
 111         our %cmp_memos;
 112         @sources = sort {
 113             memo(\%cmp_memos, "$a->{Name} $b->{Name}", sub {
 114                 my $mb = merge_base($a->{Ref}, $b->{Ref});
 115                 return -($mb eq $a->{Ref}) cmp ($mb eq $b->{Ref})
 116                     # if merge base is $a then $a must be before $b
 117                     # ie the commit equal to the merge base is earlier
 118                     or (committ_date($a->{Ref}) cmp committ_date($b->{Ref}));
 119             })
 120         } @sources;
 121
 122
 123         # Now we run git-rev-list to walk the graph back to those
 124         # sources so we can tell which is the most recent.
 125         foreach my $source (@sources) {
 126
 127
 128
 129             $source->{MergeBase} = $mergebase;
 130
 131             bad_metadata("$patch base topgit $obj") unless $obj eq 'blob';
 132
 133             # ok
 134         } elsif ($obk
 135
 136
 137 sub done ($) {
 138     our %done;
 139     return 1 if $done{$_[0]}++;
 140     debug("----- $key");
 141 }
 142
 143 sub memo ($$) {
 144     my ($key,$code) = @_;
 145     our %memo;
 146     return $memo{$key} if exists $memo{$key};
 147     debug("----- $key");
 148     $memo{$key} = $code->();
 149 }
 150
 151 sub tip_sources_core
 152
 153 sub tip_sources ($) {
 154     my ($patch) = @_;
 155     my @sources = ();
 156     push @sources, { How => 'base', Ref => "$baserefs/$patch" };
 157     foreach my $remote (get_configured_remotes()) {
 158         push @sources, { How => 'remote',
 159                          Ref => "refs/remotes/$remote/topbloke-tips/$patch" };
 160     }
 161
 162 sub compute_desired_deps ($) {
 163     my ($patch) = @_;
 164  return memo("compute_desired_deps $patch", {
 165      foreach my $sourceref (tip_source_refs($patch)) {
 166          die...
 167  });
 168 }
 169
 170 sub update_base ($) {
 171     my ($patch) = @_;
 172     return if done("update_base $patch");
 173     my @desired_deps = compute_desired_deps($patch);
 174     die...
 175
 176 sub update_deps ($) {
 177     my $patch = @_;
 178     return if done("update_deps $patch");
 179     my $deps = git_get_object("$baserefs/$patch:.topbloke/deps");
 180     foreach my $dep (split /\n/, $deps) {
 181         if ($dep =~ m/^tb /) {
 182             my $dep_patch = $'; #';
 183             update_patch($dep_patch);
 184         }
 185     }
 186 }
 187
 188 sub update_patch ($) {
 189     my $patch = @_;
 190     update_deps($patch);
 191     update_base($patch);
 192     update_tip($patch);
 193 }
 194
 195 our $current = current_branch();
 196 if ($current->{Kind} eq 'tip') {
 197     update_patch($current);
 198 } elsif ($current->{Kind} eq 'base') {
 199     update_deps($current);
 200     update_base($current);
 201 } else {
 202     die "Not a topbloke branch ($current->{Kind})\n";
 203 }