git-debrebase

   1 #!/usr/bin/perl -w
   2 # git-debrebase
   3 # Script helping make fast-forwarding histories while still rebasing
   4 # upstream deltas when working on Debian packaging
   5 #
   6 # Copyright (C)2017,2018 Ian Jackson
   7 #
   8 # This program is free software: you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation, either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 use strict;
  22
  23 use Debian::Dgit qw(:DEFAULT :playground);
  24 setup_sigwarn();
  25
  26 use Memoize;
  27 use Carp;
  28 use POSIX;
  29 use Data::Dumper;
  30 use Getopt::Long qw(:config posix_default gnu_compat bundling);
  31 use Dpkg::Version;
  32 use File::FnMatch qw(:fnmatch);
  33
  34 our ($opt_force, $opt_noop_ok, @opt_anchors);
  35
  36 our $us = qw(git-debrebase);
  37
  38 sub badusage ($) {
  39     my ($m) = @_;
  40     print STDERR "bad usage: $m\n";
  41     exit 12;
  42 }
  43
  44 sub cfg ($;$) {
  45     my ($k, $optional) = @_;
  46     local $/ = "\0";
  47     my @cmd = qw(git config -z);
  48     push @cmd, qw(--get-all) if wantarray;
  49     push @cmd, $k;
  50     my $out = cmdoutput_errok @cmd;
  51     if (!defined $out) {
  52         fail "missing required git config $k" unless $optional;
  53         return ();
  54     }
  55     my @l = split /\0/, $out;
  56     return wantarray ? @l : $l[0];
  57 }
  58
  59 memoize('cfg');
  60
  61 sub dd ($) {
  62     my ($v) = @_;
  63     my $dd = new Data::Dumper [ $v ];
  64     Terse $dd 1; Indent $dd 0; Useqq $dd 1;
  65     return Dump $dd;
  66 }
  67
  68 sub get_commit ($) {
  69     my ($objid) = @_;
  70     my $data = (git_cat_file $objid, 'commit');
  71     $data =~ m/(?<=\n)\n/ or die "$objid ($data) ?";
  72     return ($`,$');
  73 }
  74
  75 sub D_UPS ()      { 0x02; } # upstream files
  76 sub D_PAT_ADD ()  { 0x04; } # debian/patches/ extra patches at end
  77 sub D_PAT_OTH ()  { 0x08; } # debian/patches other changes
  78 sub D_DEB_CLOG () { 0x10; } # debian/ (not patches/ or changelog)
  79 sub D_DEB_OTH ()  { 0x20; } # debian/changelog
  80 sub DS_DEB ()     { D_DEB_CLOG | D_DEB_OTH; } # debian/ (not patches/)
  81
  82 our $playprefix = 'debrebase';
  83 our $rd;
  84 our $workarea;
  85
  86 our @git = qw(git);
  87
  88 sub in_workarea ($) {
  89     my ($sub) = @_;
  90     changedir $workarea;
  91     my $r = eval { $sub->(); };
  92     { local $@; changedir $maindir; }
  93     die $@ if $@;
  94 }
  95
  96 sub fresh_workarea () {
  97     $workarea = fresh_playground "$playprefix/work";
  98     in_workarea sub { playtree_setup };
  99 }
 100
 101 our @deferred_updates;
 102 our @deferred_update_messages;
 103
 104 sub run_deferred_updates ($) {
 105     my ($mrest) = @_;
 106
 107     my @upd_cmd = (@git, qw(update-ref --stdin -m), "debrebase: $mrest");
 108     debugcmd '>|', @upd_cmd;
 109     open U, "|-", @upd_cmd or die $!;
 110     foreach (@deferred_updates) {
 111         printdebug ">= ", $_, "\n";
 112         print U $_, "\n" or die $!;
 113     }
 114     printdebug ">\$\n";
 115     close U or failedcmd @upd_cmd;
 116
 117     print $_, "\n" foreach @deferred_update_messages;
 118
 119     @deferred_updates = ();
 120     @deferred_update_messages = ();
 121 }
 122
 123 sub get_differs ($$) {
 124     my ($x,$y) = @_;
 125     # This resembles quiltify_trees_differ, in dgit, a bit.
 126     # But we don't care about modes, or dpkg-source-unrepresentable
 127     # changes, and we don't need the plethora of different modes.
 128     # Conversely we need to distinguish different kinds of changes to
 129     # debian/ and debian/patches/.
 130
 131     my $differs = 0;
 132
 133     my $rundiff = sub {
 134         my ($opts, $limits, $fn) = @_;
 135         my @cmd = (@git, qw(diff-tree -z --no-renames));
 136         push @cmd, @$opts;
 137         push @cmd, "$_:" foreach $x, $y;
 138         push @cmd, '--', @$limits;
 139         my $diffs = cmdoutput @cmd;
 140         foreach (split /\0/, $diffs) { $fn->(); }
 141     };
 142
 143     $rundiff->([qw(--name-only)], [], sub {
 144         $differs |= $_ eq 'debian' ? DS_DEB : D_UPS;
 145     });
 146
 147     if ($differs & DS_DEB) {
 148         $differs &= ~DS_DEB;
 149         $rundiff->([qw(--name-only -r)], [qw(debian)], sub {
 150             $differs |=
 151                 m{^debian/patches/}      ? D_PAT_OTH  :
 152                 $_ eq 'debian/changelog' ? D_DEB_CLOG :
 153                                            D_DEB_OTH;
 154         });
 155         die "mysterious debian changes $x..$y"
 156             unless $differs & (D_PAT_OTH|DS_DEB);
 157     }
 158
 159     if ($differs & D_PAT_OTH) {
 160         my $mode;
 161         $differs &= ~D_PAT_OTH;
 162         my $pat_oth = sub {
 163             $differs |= D_PAT_OTH;
 164             no warnings qw(exiting);  last;
 165         };
 166         $rundiff->([qw(--name-status -r)], [qw(debian/patches/)], sub {
 167             no warnings qw(exiting);
 168             if (!defined $mode) {
 169                 $mode = $_;  next;
 170             }
 171             die unless s{^debian/patches/}{};
 172             my $ok;
 173             if ($mode eq 'A' && !m/\.series$/s) {
 174                 $ok = 1;
 175             } elsif ($mode eq 'M' && $_ eq 'series') {
 176                 my $x_s = (git_cat_file "$x:debian/patches/series", 'blob');
 177                 my $y_s = (git_cat_file "$y:debian/patches/series", 'blob');
 178                 chomp $x_s;  $x_s .= "\n";
 179                 $ok = $x_s eq substr($y_s, 0, length $x_s);
 180             } else {
 181                 # nope
 182             }
 183             $mode = undef;
 184             $differs |= $ok ? D_PAT_ADD : D_PAT_OTH;
 185         });
 186         die "mysterious debian/patches changes $x..$y"
 187             unless $differs & (D_PAT_ADD|D_PAT_OTH);
 188     }
 189
 190     printdebug sprintf "get_differs %s, %s = %#x\n", $x, $y, $differs;
 191
 192     return $differs;
 193 }
 194
 195 sub commit_pr_info ($) {
 196     my ($r) = @_;
 197     return Data::Dumper->dump([$r], [qw(commit)]);
 198 }
 199
 200 sub calculate_committer_authline () {
 201     my $c = cmdoutput @git, qw(commit-tree --no-gpg-sign -m),
 202         'DUMMY COMMIT (git-debrebase)', "HEAD:";
 203     my ($h,$m) = get_commit $c;
 204     $h =~ m/^committer .*$/m or confess "($h) ?";
 205     return $&;
 206 }
 207
 208 sub rm_subdir_cached ($) {
 209     my ($subdir) = @_;
 210     runcmd @git, qw(rm --quiet -rf --cached --ignore-unmatch), $subdir;
 211 }
 212
 213 sub read_tree_subdir ($$) {
 214     my ($subdir, $new_tree_object) = @_;
 215     rm_subdir_cached $subdir;
 216     runcmd @git, qw(read-tree), "--prefix=$subdir/", $new_tree_object;
 217 }
 218
 219 sub make_commit ($$) {
 220     my ($parents, $message_paras) = @_;
 221     my $tree = cmdoutput @git, qw(write-tree);
 222     my @cmd = (@git, qw(commit-tree), $tree);
 223     push @cmd, qw(-p), $_ foreach @$parents;
 224     push @cmd, qw(-m), $_ foreach @$message_paras;
 225     return cmdoutput @cmd;
 226 }
 227
 228 our @snag_force_opts;
 229 our $snags_forced;
 230 our $snags_tripped;
 231 sub snag ($$) {
 232     my ($tag,$msg) = @_;
 233     if (grep { $_ eq $tag } @snag_force_opts) {
 234         $snags_forced++;
 235         print STDERR "git-debrebase: snag ignored (-f$tag): $msg\n";
 236     } else {
 237         $snags_tripped++;
 238         print STDERR "git-debrebase: snag detected (-f$tag): $msg\n";
 239     }
 240 }
 241
 242 sub snags_maybe_bail () {
 243     if ($snags_forced) {
 244         printf STDERR
 245             "%s: snags: %d overriden by individual -f options\n",
 246             $us, $snags_forced;
 247     }
 248     if ($snags_tripped) {
 249         if ($opt_force) {
 250             printf STDERR
 251                 "%s: snags: %d overriden by global --force\n",
 252                 $us, $snags_tripped;
 253         } else {
 254             fail sprintf
 255   "%s: snags: %d blockers (you could -f<tag>, or --force)",
 256                 $us, $snags_tripped;
 257         }
 258     }
 259 }
 260 sub any_snags () {
 261     return $snags_forced || $snags_tripped;
 262 }
 263
 264 # classify returns an info hash like this
 265 #   CommitId => $objid
 266 #   Hdr => # commit headers, including 1 final newline
 267 #   Msg => # commit message (so one newline is dropped)
 268 #   Tree => $treeobjid
 269 #   Type => (see below)
 270 #   Parents = [ {
 271 #       Ix => $index # ie 0, 1, 2, ...
 272 #       CommitId
 273 #       Differs => return value from get_differs
 274 #       IsOrigin
 275 #       IsDggitImport => 'orig' 'tarball' 'unpatched' 'package' (as from dgit)
 276 #     } ...]
 277 #   NewMsg => # commit message, but with any [dgit import ...] edited
 278 #             # to say "[was: ...]"
 279 #
 280 # Types:
 281 #   Packaging
 282 #   Changelog
 283 #   Upstream
 284 #   AddPatches
 285 #   Mixed
 286 #
 287 #   Pseudomerge
 288 #     has additional entres in classification result
 289 #       Overwritten = [ subset of Parents ]
 290 #       Contributor = $the_remaining_Parent
 291 #
 292 #   DgitImportUnpatched
 293 #     has additional entry in classification result
 294 #       OrigParents = [ subset of Parents ]
 295 #
 296 #   Anchor
 297 #     has additional entry in classification result
 298 #       OrigParents = [ subset of Parents ]  # singleton list
 299 #
 300 #   TreatAsAnchor
 301 #
 302 #   BreakwaterStart
 303 #
 304 #   Unknown
 305 #     has additional entry in classification result
 306 #       Why => "prose"
 307
 308 sub parsecommit ($;$) {
 309     my ($objid, $p_ref) = @_;
 310     # => hash with                   CommitId Hdr Msg Tree Parents
 311     #    Parents entries have only   Ix CommitId
 312     #    $p_ref, if provided, must be [] and is used as a base for Parents
 313
 314     $p_ref //= [];
 315     die if @$p_ref;
 316
 317     my ($h,$m) = get_commit $objid;
 318
 319     my ($t) = $h =~ m/^tree (\w+)$/m or die $objid;
 320     my (@ph) = $h =~ m/^parent (\w+)$/mg;
 321
 322     my $r = {
 323         CommitId => $objid,
 324         Hdr => $h,
 325         Msg => $m,
 326         Tree => $t,
 327         Parents => $p_ref,
 328     };
 329
 330     foreach my $ph (@ph) {
 331         push @$p_ref, {
 332             Ix => scalar @$p_ref,
 333             CommitId => $ph,
 334         };
 335     }
 336
 337     return $r;
 338 }
 339
 340 sub classify ($) {
 341     my ($objid) = @_;
 342
 343     my @p;
 344     my $r = parsecommit($objid, \@p);
 345     my $t = $r->{Tree};
 346
 347     foreach my $p (@p) {
 348         $p->{Differs} = (get_differs $p->{CommitId}, $t),
 349     }
 350
 351     printdebug "classify $objid \$t=$t \@p",
 352         (map { sprintf " %s/%#x", $_->{CommitId}, $_->{Differs} } @p),
 353         "\n";
 354
 355     my $classify = sub {
 356         my ($type, @rest) = @_;
 357         $r = { %$r, Type => $type, @rest };
 358         if ($debuglevel) {
 359             printdebug " = $type ".(dd $r)."\n";
 360         }
 361         return $r;
 362     };
 363     my $unknown = sub {
 364         my ($why) = @_;
 365         $r = { %$r, Type => qw(Unknown), Why => $why };
 366         printdebug " ** Unknown\n";
 367         return $r;
 368     };
 369
 370     if (grep { $_ eq $objid } @opt_anchors) {
 371         return $classify->('TreatAsAnchor');
 372     }
 373
 374     my @identical = grep { !$_->{Differs} } @p;
 375     my ($stype, $series) = git_cat_file "$t:debian/patches/series";
 376     my $haspatches = $stype ne 'missing' && $series =~ m/^\s*[^#\n\t ]/m;
 377
 378     if ($r->{Msg} =~ m{^\[git-debrebase anchor.*\]$}m) {
 379         # multi-orig upstreams are represented with an anchor merge
 380         # from a single upstream commit which combines the orig tarballs
 381
 382         # Every anchor tagged this way must be a merge.
 383         # We are relying on the
 384         #     [git-debrebase anchor: ...]
 385         # commit message annotation in "declare" anchor merges (which
 386         # do not have any upstream changes), to distinguish those
 387         # anchor merges from ordinary pseudomerges (which we might
 388         # just try to strip).
 389         #
 390         # However, the user is going to be doing git-rebase a lot.  We
 391         # really don't want them to rewrite an anchor commit.
 392         # git-rebase trips up on merges, so that is a useful safety
 393         # catch.
 394         #
 395         # BreakwaterStart commits are also anchors in the terminology
 396         # of git-debrebase(5), but they are untagged (and always
 397         # manually generated).
 398
 399         my $badanchor = sub { $unknown->("git-debrebase \`anchor' but @_"); };
 400         @p == 2 or return $badanchor->("has other than two parents");
 401         $haspatches and return $badanchor->("contains debian/patches");
 402
 403         # How to decide about l/r ordering of anchors ?  git
 404         # --topo-order prefers to expand 2nd parent first.  There's
 405         # already an easy rune to look for debian/ history anyway (git log
 406         # debian/) so debian breakwater branch should be 1st parent; that
 407         # way also there's also an easy rune to look for the upstream
 408         # patches (--topo-order).
 409
 410         $p[0]{IsOrigin} and $badanchor->("is an origin commit");
 411         $p[1]{Differs} & ~DS_DEB and
 412             $badanchor->("upstream files differ from left parent");
 413         $p[0]{Differs} & ~D_UPS and
 414             $badanchor->("debian/ differs from right parent");
 415
 416         return $classify->(qw(Anchor),
 417                            OrigParents => [ $p[1] ]);
 418     }
 419
 420     if (@p == 1) {
 421         my $d = $r->{Parents}[0]{Differs};
 422         if ($d == D_PAT_ADD) {
 423             return $classify->(qw(AddPatches));
 424         } elsif ($d & (D_PAT_ADD|D_PAT_OTH)) {
 425             return $unknown->("edits debian/patches");
 426         } elsif ($d & DS_DEB and !($d & ~DS_DEB)) {
 427             my ($ty,$dummy) = git_cat_file "$p[0]{CommitId}:debian";
 428             if ($ty eq 'tree') {
 429                 if ($d == D_DEB_CLOG) {
 430                     return $classify->(qw(Changelog));
 431                 } else {
 432                     return $classify->(qw(Packaging));
 433                 }
 434             } elsif ($ty eq 'missing') {
 435                 return $classify->(qw(BreakwaterStart));
 436             } else {
 437                 return $unknown->("parent's debian is not a directory");
 438             }
 439         } elsif ($d == D_UPS) {
 440             return $classify->(qw(Upstream));
 441         } elsif ($d & DS_DEB and $d & D_UPS and !($d & ~(DS_DEB|D_UPS))) {
 442             return $classify->(qw(Mixed));
 443         } elsif ($d == 0) {
 444             return $unknown->("no changes");
 445         } else {
 446             confess "internal error $objid ?";
 447         }
 448     }
 449     if (!@p) {
 450         return $unknown->("origin commit");
 451     }
 452
 453     if (@p == 2 && @identical == 1) {
 454         my @overwritten = grep { $_->{Differs} } @p;
 455         confess "internal error $objid ?" unless @overwritten==1;
 456         return $classify->(qw(Pseudomerge),
 457                            Overwritten => [ $overwritten[0] ],
 458                            Contributor => $identical[0]);
 459     }
 460     if (@p == 2 && @identical == 2) {
 461         my $get_t = sub {
 462             my ($ph,$pm) = get_commit $_[0]{CommitId};
 463             $ph =~ m/^committer .* (\d+) [-+]\d+$/m or die "$_->{CommitId} ?";
 464             $1;
 465         };
 466         my @bytime = @p;
 467         my $order = $get_t->($bytime[0]) <=> $get_t->($bytime[1]);
 468         if ($order > 0) { # newer first
 469         } elsif ($order < 0) {
 470             @bytime = reverse @bytime;
 471         } else {
 472             # same age, default to order made by -s ours
 473             # that is, commit was made by someone who preferred L
 474         }
 475         return $classify->(qw(Pseudomerge),
 476                            SubType => qw(Ambiguous),
 477                            Contributor => $bytime[0],
 478                            Overwritten => [ $bytime[1] ]);
 479     }
 480     foreach my $p (@p) {
 481         my ($p_h, $p_m) = get_commit $p->{CommitId};
 482         $p->{IsOrigin} = $p_h !~ m/^parent \w+$/m;
 483         ($p->{IsDgitImport},) = $p_m =~ m/^\[dgit import ([0-9a-z]+) .*\]$/m;
 484     }
 485     my @orig_ps = grep { ($_->{IsDgitImport}//'X') eq 'orig' } @p;
 486     my $m2 = $r->{Msg};
 487     if (!(grep { !$_->{IsOrigin} } @p) and
 488         (@orig_ps >= @p - 1) and
 489         $m2 =~ s{^\[(dgit import unpatched .*)\]$}{[was: $1]}m) {
 490         $r->{NewMsg} = $m2;
 491         return $classify->(qw(DgitImportUnpatched),
 492                            OrigParents => \@orig_ps);
 493     }
 494
 495     return $unknown->("complex merge");
 496 }
 497
 498 sub keycommits ($;$$$) {
 499     my ($head, $furniture, $unclean, $trouble) = @_;
 500     # => ($anchor, $breakwater)
 501
 502     # $unclean->("unclean-$tagsfx", $msg)
 503     # $furniture->("unclean-$tagsfx", $msg)
 504     # $dgitimport->("unclean-$tagsfx", $msg)
 505     #   is callled for each situation or commit that
 506     #   wouldn't be found in a laundered branch
 507     # $furniture is for furniture commits such as might be found on an
 508     #   interchange branch (pseudomerge, d/patches, changelog)
 509     # $trouble is for things whnich prevent the return of
 510     #   anchor and breakwater information; if that is ignored,
 511     #   then keycommits returns (undef, undef) instead.
 512     #
 513     # If a callback is undef, fail is called instead.
 514     # If a callback is defined but false, the situation is ignored.
 515     # Callbacks may say:
 516     #   no warnings qw(exiting); last;
 517     # if the answer is no longer wanted.
 518
 519     my ($anchor, $breakwater);
 520     my $clogonly;
 521     my $x = sub {
 522         my ($cb, $tagsfx, $why) = @_;
 523         my $m = "branch needs laundering (run git-debrebase): $why";
 524         fail $m unless defined $cb;
 525         return unless $cb;
 526         $cb->("unclean-$tagsfx", $why);
 527     };
 528     for (;;) {
 529         my $cl = classify $head;
 530         my $ty = $cl->{Type};
 531         if ($ty eq 'Packaging') {
 532             $breakwater //= $clogonly;
 533             $breakwater //= $head;
 534         } elsif ($ty eq 'Changelog') {
 535             # this is going to count as the tip of the breakwater
 536             # only if it has no upstream stuff before it
 537             $clogonly //= $head;
 538         } elsif ($ty eq 'Anchor' or
 539                  $ty eq 'TreatAsAnchor' or
 540                  $ty eq 'BreakwaterStart') {
 541             $anchor = $head;
 542             $breakwater //= $clogonly;
 543             $breakwater //= $head;
 544             last;
 545         } elsif ($ty eq 'Upstream') {
 546             $x->($unclean, 'ordering',
 547  "packaging change ($breakwater) follows upstream change (eg $head)")
 548                 if defined $breakwater;
 549             $clogonly = undef;
 550             $breakwater = undef;
 551         } elsif ($ty eq 'Mixed') {
 552             $x->($unclean, 'mixed',
 553                  'found mixed upstream/packaging commit ($head)');
 554             $clogonly = undef;
 555             $breakwater = undef;
 556         } elsif ($ty eq 'Pseudomerge' or
 557                  $ty eq 'AddPatches') {
 558             $x->($furniture, (lc $ty),
 559                  "found interchange bureaucracy commit ($ty, $head)");
 560         } elsif ($ty eq 'DgitImportUnpatched') {
 561             $x->($trouble, 'dgitimport',
 562                  "found dgit dsc import ($head)");
 563             $breakwater = undef;
 564             $anchor = undef;
 565             no warnings qw(exiting);
 566             last;
 567         } else {
 568             fail "found unprocessable commit, cannot cope: $head; $cl->{Why}";
 569         }
 570         $head = $cl->{Parents}[0]{CommitId};
 571     }
 572     return ($anchor, $breakwater);
 573 }
 574
 575 sub walk ($;$$);
 576 sub walk ($;$$) {
 577     my ($input,
 578         $nogenerate,$report) = @_;
 579     # => ($tip, $breakwater_tip, $last_anchor)
 580     # (or nothing, if $nogenerate)
 581
 582     printdebug "*** WALK $input ".($nogenerate//0)." ".($report//'-')."\n";
 583
 584     # go through commits backwards
 585     # we generate two lists of commits to apply:
 586     # breakwater branch and upstream patches
 587     my (@brw_cl, @upp_cl, @processed);
 588     my %found;
 589     my $upp_limit;
 590     my @pseudomerges;
 591
 592     my $cl;
 593     my $xmsg = sub {
 594         my ($prose, $info) = @_;
 595         my $ms = $cl->{Msg};
 596         chomp $ms;
 597         $info //= '';
 598         $ms .= "\n\n[git-debrebase$info: $prose]\n";
 599         return (Msg => $ms);
 600     };
 601     my $rewrite_from_here = sub {
 602         my ($cl) = @_;
 603         my $sp_cl = { SpecialMethod => 'StartRewrite' };
 604         push @$cl, $sp_cl;
 605         push @processed, $sp_cl;
 606     };
 607     my $cur = $input;
 608
 609     my $prdelim = "";
 610     my $prprdelim = sub { print $report $prdelim if $report; $prdelim=""; };
 611
 612     my $prline = sub {
 613         return unless $report;
 614         print $report $prdelim, @_;
 615         $prdelim = "\n";
 616     };
 617
 618     my $bomb = sub { # usage: return $bomb->();
 619         print $report " Unprocessable" if $report;
 620         print $report " ($cl->{Why})" if $report && defined $cl->{Why};
 621         $prprdelim->();
 622         if ($nogenerate) {
 623             return (undef,undef);
 624         }
 625         die "commit $cur: Cannot cope with this commit (d.".
 626             (join ' ', map { sprintf "%#x", $_->{Differs} }
 627              @{ $cl->{Parents} }).
 628             (defined $cl->{Why} ? "; $cl->{Why}": '').
 629                  ")";
 630     };
 631
 632     my $build;
 633     my $breakwater;
 634
 635     my $build_start = sub {
 636         my ($msg, $parent) = @_;
 637         $prline->(" $msg");
 638         $build = $parent;
 639         no warnings qw(exiting); last;
 640     };
 641
 642     my $last_anchor;
 643
 644     for (;;) {
 645         $cl = classify $cur;
 646         my $ty = $cl->{Type};
 647         my $st = $cl->{SubType};
 648         $prline->("$cl->{CommitId} $cl->{Type}");
 649         $found{$ty. ( defined($st) ? "-$st" : '' )}++;
 650         push @processed, $cl;
 651         my $p0 = @{ $cl->{Parents} }==1 ? $cl->{Parents}[0]{CommitId} : undef;
 652         if ($ty eq 'AddPatches') {
 653             $cur = $p0;
 654             $rewrite_from_here->(\@upp_cl);
 655             next;
 656         } elsif ($ty eq 'Packaging' or $ty eq 'Changelog') {
 657             push @brw_cl, $cl;
 658             $cur = $p0;
 659             next;
 660         } elsif ($ty eq 'BreakwaterStart') {
 661             $last_anchor = $cur;
 662             $build_start->('FirstPackaging', $cur);
 663         } elsif ($ty eq 'Upstream') {
 664             push @upp_cl, $cl;
 665             $cur = $p0;
 666             next;
 667         } elsif ($ty eq 'Mixed') {
 668             my $queue = sub {
 669                 my ($q, $wh) = @_;
 670                 my $cls = { %$cl, $xmsg->("split mixed commit: $wh part") };
 671                 push @$q, $cls;
 672             };
 673             $queue->(\@brw_cl, "debian");
 674             $queue->(\@upp_cl, "upstream");
 675             $rewrite_from_here->(\@brw_cl);
 676             $cur = $p0;
 677             next;
 678         } elsif ($ty eq 'Pseudomerge') {
 679             my $contrib = $cl->{Contributor}{CommitId};
 680             print $report " Contributor=$contrib" if $report;
 681             push @pseudomerges, $cl;
 682             $rewrite_from_here->(\@upp_cl);
 683             $cur = $contrib;
 684             next;
 685         } elsif ($ty eq 'Anchor' or $ty eq 'TreatAsAnchor') {
 686             $last_anchor = $cur;
 687             $build_start->("Anchor", $cur);
 688         } elsif ($ty eq 'DgitImportUnpatched') {
 689             my $pm = $pseudomerges[-1];
 690             if (defined $pm) {
 691                 # To an extent, this is heuristic.  Imports don't have
 692                 # a useful history of the debian/ branch.  We assume
 693                 # that the first pseudomerge after an import has a
 694                 # useful history of debian/, and ignore the histories
 695                 # from later pseudomerges.  Often the first pseudomerge
 696                 # will be the dgit import of the upload to the actual
 697                 # suite intended by the non-dgit NMUer, and later
 698                 # pseudomerges may represent in-archive copies.
 699                 my $ovwrs = $pm->{Overwritten};
 700                 printf $report " PM=%s \@Overwr:%d",
 701                     $pm->{CommitId}, (scalar @$ovwrs)
 702                     if $report;
 703                 if (@$ovwrs != 1) {
 704                     printdebug "*** WALK BOMB DgitImportUnpatched\n";
 705                     return $bomb->();
 706                 }
 707                 my $ovwr = $ovwrs->[0]{CommitId};
 708                 printf $report " Overwr=%s", $ovwr if $report;
 709                 # This import has a tree which is just like a
 710                 # breakwater tree, but it has the wrong history.  It
 711                 # ought to have the previous breakwater (which the
 712                 # pseudomerge overwrote) as an ancestor.  That will
 713                 # make the history of the debian/ files correct.  As
 714                 # for the upstream version: either it's the same as
 715                 # was ovewritten (ie, same as the previous
 716                 # breakwater), in which case that history is precisely
 717                 # right; or, otherwise, it was a non-gitish upload of a
 718                 # new upstream version.  We can tell these apart by
 719                 # looking at the tree of the supposed upstream.
 720                 push @brw_cl, {
 721                     %$cl,
 722                     SpecialMethod => 'DgitImportDebianUpdate',
 723                     $xmsg->("convert dgit import: debian changes")
 724                 }, {
 725                     %$cl,
 726                     SpecialMethod => 'DgitImportUpstreamUpdate',
 727                     $xmsg->("convert dgit import: upstream update",
 728                             " anchor")
 729                 };
 730                 $prline->(" Import");
 731                 $rewrite_from_here->(\@brw_cl);
 732                 $upp_limit //= $#upp_cl; # further, deeper, patches discarded
 733                 $cur = $ovwr;
 734                 next;
 735             } else {
 736                 # Everything is from this import.  This kind of import
 737                 # is already in valid breakwater format, with the
 738                 # patches as commits.
 739                 printf $report " NoPM" if $report;
 740                 # last thing we processed will have been the first patch,
 741                 # if there is one; which is fine, so no need to rewrite
 742                 # on account of this import
 743                 $build_start->("ImportOrigin", $cur);
 744             }
 745             die "$ty ?";
 746         } else {
 747             printdebug "*** WALK BOMB unrecognised\n";
 748             return $bomb->();
 749         }
 750     }
 751     $prprdelim->();
 752
 753     printdebug "*** WALK prep done cur=$cur".
 754         " brw $#brw_cl upp $#upp_cl proc $#processed pm $#pseudomerges\n";
 755
 756     return if $nogenerate;
 757
 758     # Now we build it back up again
 759
 760     fresh_workarea();
 761
 762     my $rewriting = 0;
 763
 764     my $read_tree_debian = sub {
 765         my ($treeish) = @_;
 766         read_tree_subdir 'debian', "$treeish:debian";
 767         rm_subdir_cached 'debian/patches';
 768     };
 769     my $read_tree_upstream = sub {
 770         my ($treeish) = @_;
 771         runcmd @git, qw(read-tree), $treeish;
 772         $read_tree_debian->($build);
 773     };
 774
 775     $#upp_cl = $upp_limit if defined $upp_limit;
 776
 777     my $committer_authline = calculate_committer_authline();
 778
 779     printdebug "WALK REBUILD $build ".(scalar @processed)."\n";
 780
 781     confess "internal error" unless $build eq (pop @processed)->{CommitId};
 782
 783     in_workarea sub {
 784         mkdir $rd or $!==EEXIST or die $!;
 785         my $current_method;
 786         runcmd @git, qw(read-tree), $build;
 787         foreach my $cl (qw(Debian), (reverse @brw_cl),
 788                         { SpecialMethod => 'RecordBreakwaterTip' },
 789                         qw(Upstream), (reverse @upp_cl)) {
 790             if (!ref $cl) {
 791                 $current_method = $cl;
 792                 next;
 793             }
 794             my $method = $cl->{SpecialMethod} // $current_method;
 795             my @parents = ($build);
 796             my $cltree = $cl->{CommitId};
 797             printdebug "WALK BUILD ".($cltree//'undef').
 798                 " $method (rewriting=$rewriting)\n";
 799             if ($method eq 'Debian') {
 800                 $read_tree_debian->($cltree);
 801             } elsif ($method eq 'Upstream') {
 802                 $read_tree_upstream->($cltree);
 803             } elsif ($method eq 'StartRewrite') {
 804                 $rewriting = 1;
 805                 next;
 806             } elsif ($method eq 'RecordBreakwaterTip') {
 807                 $breakwater = $build;
 808                 next;
 809             } elsif ($method eq 'DgitImportDebianUpdate') {
 810                 $read_tree_debian->($cltree);
 811             } elsif ($method eq 'DgitImportUpstreamUpdate') {
 812                 confess unless $rewriting;
 813                 my $differs = (get_differs $build, $cltree);
 814                 next unless $differs & D_UPS;
 815                 $read_tree_upstream->($cltree);
 816                 push @parents, map { $_->{CommitId} } @{ $cl->{OrigParents} };
 817             } else {
 818                 confess "$method ?";
 819             }
 820             if (!$rewriting) {
 821                 my $procd = (pop @processed) // 'UNDEF';
 822                 if ($cl ne $procd) {
 823                     $rewriting = 1;
 824                     printdebug "WALK REWRITING NOW cl=$cl procd=$procd\n";
 825                 }
 826             }
 827             my $newtree = cmdoutput @git, qw(write-tree);
 828             my $ch = $cl->{Hdr};
 829             $ch =~ s{^tree .*}{tree $newtree}m or confess "$ch ?";
 830             $ch =~ s{^parent .*\n}{}mg;
 831             $ch =~ s{(?=^author)}{
 832                 join '', map { "parent $_\n" } @parents
 833             }me or confess "$ch ?";
 834             if ($rewriting) {
 835                 $ch =~ s{^committer .*$}{$committer_authline}m
 836                     or confess "$ch ?";
 837             }
 838             my $cf = "$rd/m$rewriting";
 839             open CD, ">", $cf or die $!;
 840             print CD $ch, "\n", $cl->{Msg} or die $!;
 841             close CD or die $!;
 842             my @cmd = (@git, qw(hash-object));
 843             push @cmd, qw(-w) if $rewriting;
 844             push @cmd, qw(-t commit), $cf;
 845             my $newcommit = cmdoutput @cmd;
 846             confess "$ch ?" unless $rewriting or $newcommit eq $cl->{CommitId};
 847             $build = $newcommit;
 848             if (grep { $method eq $_ } qw(DgitImportUpstreamUpdate)) {
 849                 $last_anchor = $cur;
 850             }
 851         }
 852     };
 853
 854     my $final_check = get_differs $build, $input;
 855     die sprintf "internal error %#x %s %s", $final_check, $build, $input
 856         if $final_check & ~D_PAT_ADD;
 857
 858     my @r = ($build, $breakwater, $last_anchor);
 859     printdebug "*** WALK RETURN @r\n";
 860     return @r
 861 }
 862
 863 sub get_head () {
 864     git_check_unmodified();
 865     return git_rev_parse qw(HEAD);
 866 }
 867
 868 sub update_head ($$$) {
 869     my ($old, $new, $mrest) = @_;
 870     push @deferred_updates, "update HEAD $new $old";
 871     run_deferred_updates $mrest;
 872 }
 873
 874 sub update_head_checkout ($$$) {
 875     my ($old, $new, $mrest) = @_;
 876     update_head $old, $new, $mrest;
 877     runcmd @git, qw(reset --hard);
 878 }
 879
 880 sub update_head_postlaunder ($$$) {
 881     my ($old, $tip, $reflogmsg) = @_;
 882     return if $tip eq $old;
 883     print "git-debrebase: laundered (head was $old)\n";
 884     update_head $old, $tip, $reflogmsg;
 885     # no tree changes except debian/patches
 886     runcmd @git, qw(rm --quiet --ignore-unmatch -rf debian/patches);
 887 }
 888
 889 sub do_launder_head ($) {
 890     my ($reflogmsg) = @_;
 891     my $old = get_head();
 892     record_ffq_auto();
 893     my ($tip,$breakwater) = walk $old;
 894     update_head_postlaunder $old, $tip, $reflogmsg;
 895     return ($tip,$breakwater);
 896 }
 897
 898 sub cmd_launder_v0 () {
 899     badusage "no arguments to launder-v0 allowed" if @ARGV;
 900     my $old = get_head();
 901     my ($tip,$breakwater,$last_anchor) = walk $old;
 902     update_head_postlaunder $old, $tip, 'launder';
 903     printf "# breakwater tip\n%s\n", $breakwater;
 904     printf "# working tip\n%s\n", $tip;
 905     printf "# last anchor\n%s\n", $last_anchor;
 906 }
 907
 908 sub defaultcmd_rebase () {
 909     my ($tip,$breakwater) = do_launder_head 'launder for rebase';
 910     runcmd @git, qw(rebase), @ARGV, $breakwater;
 911 }
 912
 913 sub cmd_analyse () {
 914     die if ($ARGV[0]//'') =~ m/^-/;
 915     badusage "too many arguments to analyse" if @ARGV>1;
 916     my ($old) = @ARGV;
 917     if (defined $old) {
 918         $old = git_rev_parse $old;
 919     } else {
 920         $old = git_rev_parse 'HEAD';
 921     }
 922     my ($dummy,$breakwater) = walk $old, 1,*STDOUT;
 923     STDOUT->error and die $!;
 924 }
 925
 926 sub ffq_prev_branchinfo () {
 927     # => ('status', "message", [$current, $ffq_prev, $gdrlast])
 928     # 'status' may be
 929     #    branch         message is undef
 930     #    weird-symref   } no $current,
 931     #    notbranch      }  no $ffq_prev
 932     my $current = git_get_symref();
 933     return ('detached', 'detached HEAD') unless defined $current;
 934     return ('weird-symref', 'HEAD symref is not to refs/')
 935         unless $current =~ m{^refs/};
 936     my $ffq_prev = "refs/$ffq_refprefix/$'";
 937     my $gdrlast = "refs/$gdrlast_refprefix/$'";
 938     printdebug "ffq_prev_branchinfo branch current $current\n";
 939     return ('branch', undef, $current, $ffq_prev, $gdrlast);
 940 }
 941
 942 sub record_ffq_prev_deferred () {
 943     # => ('status', "message")
 944     # 'status' may be
 945     #    deferred          message is undef
 946     #    exists
 947     #    detached
 948     #    weird-symref
 949     #    notbranch
 950     # if not ff from some branch we should be ff from, is an snag
 951     # if "deferred", will have added something about that to
 952     #   @deferred_update_messages, and also maybe printed (already)
 953     #   some messages about ff checks
 954     my ($status, $message, $current, $ffq_prev, $gdrlast)
 955         = ffq_prev_branchinfo();
 956     return ($status, $message) unless $status eq 'branch';
 957
 958     my $currentval = get_head();
 959
 960     my $exists = git_get_ref $ffq_prev;
 961     return ('exists',"$ffq_prev already exists") if $exists;
 962
 963     return ('not-branch', 'HEAD symref is not to refs/heads/')
 964         unless $current =~ m{^refs/heads/};
 965     my $branch = $';
 966
 967     my @check_specs = split /\;/, (cfg "branch.$branch.ffq-ffrefs",1) // '*';
 968     my %checked;
 969
 970     printdebug "ffq check_specs @check_specs\n";
 971
 972     my $check = sub {
 973         my ($lrref, $desc) = @_;
 974         printdebug "ffq might check $lrref ($desc)\n";
 975         my $invert;
 976         for my $chk (@check_specs) {
 977             my $glob = $chk;
 978             $invert = $glob =~ s{^[!^]}{};
 979             last if fnmatch $glob, $lrref;
 980         }
 981         return if $invert;
 982         my $lrval = git_get_ref $lrref;
 983         return unless defined $lrval;
 984
 985         if (is_fast_fwd $lrval, $currentval) {
 986             print "OK, you are ahead of $lrref\n" or die $!;
 987             $checked{$lrref} = 1;
 988         } elsif (is_fast_fwd $currentval, $lrval) {
 989             $checked{$lrref} = -1;
 990             snag 'behind', "you are behind $lrref, divergence risk";
 991         } else {
 992             $checked{$lrref} = -1;
 993             snag 'diverged', "you have diverged from $lrref";
 994         }
 995     };
 996
 997     my $merge = cfg "branch.$branch.merge",1;
 998     if (defined $merge and $merge =~ m{^refs/heads/}) {
 999         my $rhs = $';
1000         printdebug "ffq merge $rhs\n";
1001         my $check_remote = sub {
1002             my ($remote, $desc) = @_;
1003             printdebug "ffq check_remote ".($remote//'undef')." $desc\n";
1004             return unless defined $remote;
1005             $check->("refs/remotes/$remote/$rhs", $desc);
1006         };
1007         $check_remote->((scalar cfg "branch.$branch.remote",1),
1008                         'remote fetch/merge branch');
1009         $check_remote->((scalar cfg "branch.$branch.pushRemote",1) //
1010                         (scalar cfg "branch.$branch.pushDefault",1),
1011                         'remote push branch');
1012     }
1013     if ($branch =~ m{^dgit/}) {
1014         $check->("refs/remotes/dgit/$branch", 'remote dgit branch');
1015     } elsif ($branch =~ m{^master$}) {
1016         $check->("refs/remotes/dgit/dgit/sid", 'remote dgit branch for sid');
1017     }
1018
1019     snags_maybe_bail();
1020
1021     push @deferred_updates, "update $ffq_prev $currentval $git_null_obj";
1022     push @deferred_updates, "delete $gdrlast";
1023     push @deferred_update_messages, "Recorded current head for preservation";
1024     return ('deferred', undef);
1025 }
1026
1027 sub record_ffq_auto () {
1028     my ($status, $message) = record_ffq_prev_deferred();
1029     if ($status eq 'deferred' || $status eq 'exists') {
1030     } else {
1031         snag $status, "could not record ffq-prev: $message";
1032         snags_maybe_bail();
1033     }
1034 }
1035
1036 sub ffq_prev_info () {
1037     # => ($ffq_prev, $gdrlast, $ffq_prev_commitish)
1038     my ($status, $message, $current, $ffq_prev, $gdrlast)
1039         = ffq_prev_branchinfo();
1040     if ($status ne 'branch') {
1041         snag $status, "could not check ffq-prev: $message";
1042         snags_maybe_bail();
1043     }
1044     my $ffq_prev_commitish = $ffq_prev && git_get_ref $ffq_prev;
1045     return ($ffq_prev, $gdrlast, $ffq_prev_commitish);
1046 }
1047
1048 sub stitch ($$$$$) {
1049     my ($old_head, $ffq_prev, $gdrlast, $ffq_prev_commitish, $prose) = @_;
1050
1051     push @deferred_updates, "delete $ffq_prev $ffq_prev_commitish";
1052
1053     if (is_fast_fwd $old_head, $ffq_prev_commitish) {
1054         my $differs = get_differs $old_head, $ffq_prev_commitish;
1055         unless ($differs & ~D_PAT_ADD) {
1056             # ffq-prev is ahead of us, and the only tree changes it has
1057             # are possibly addition of things in debian/patches/.
1058             # Just wind forwards rather than making a pointless pseudomerge.
1059             push @deferred_updates,
1060                 "update $gdrlast $ffq_prev_commitish $git_null_obj";
1061             update_head_checkout $old_head, $ffq_prev_commitish,
1062                 "stitch (fast forward)";
1063             return;
1064         }
1065     }
1066     fresh_workarea();
1067     my $new_head = make_commit [ $old_head, $ffq_prev ], [
1068         'Declare fast forward / record previous work',
1069         "[git-debrebase pseudomerge: $prose]",
1070     ];
1071     push @deferred_updates, "update $gdrlast $new_head $git_null_obj";
1072     update_head $old_head, $new_head, "stitch: $prose";
1073 }
1074
1075 sub do_stitch ($) {
1076     my ($prose) = @_;
1077
1078     my ($ffq_prev, $gdrlast, $ffq_prev_commitish) = ffq_prev_info();
1079     if (!$ffq_prev_commitish) {
1080         fail "No ffq-prev to stitch." unless $opt_noop_ok;
1081         return;
1082     }
1083     my $dangling_head = get_head();
1084
1085     keycommits $dangling_head, \&snag, \&snag, \&snag;
1086
1087     stitch($dangling_head, $ffq_prev, $gdrlast, $ffq_prev_commitish, $prose);
1088 }
1089
1090 sub cmd_new_upstream_v0 () {
1091     # automatically and unconditionally launders before rebasing
1092     # if rebase --abort is used, laundering has still been done
1093
1094     my %pieces;
1095
1096     badusage "need NEW-VERSION [UPS-COMMITTISH]" unless @ARGV >= 1;
1097
1098     # parse args - low commitment
1099     my $new_version = (new Dpkg::Version scalar(shift @ARGV), check => 1);
1100     my $new_upstream_version = $new_version->version();
1101
1102     my $new_upstream = git_rev_parse (shift @ARGV // 'upstream');
1103
1104     record_ffq_auto();
1105
1106     my $piece = sub {
1107         my ($n, @x) = @_; # may be ''
1108         my $pc = $pieces{$n} //= {
1109             Name => $n,
1110             Desc => ($n ? "upstream piece \`$n'" : "upstream (main piece"),
1111         };
1112         while (my $k = shift @x) { $pc->{$k} = shift @x; }
1113         $pc;
1114     };
1115
1116     my @newpieces;
1117     my $newpiece = sub {
1118         my ($n, @x) = @_; # may be ''
1119         my $pc = $piece->($n, @x, NewIx => (scalar @newpieces));
1120         push @newpieces, $pc;
1121     };
1122
1123     $newpiece->('',
1124         OldIx => 0,
1125         New => $new_upstream,
1126     );
1127     while (@ARGV && $ARGV[0] !~ m{^-}) {
1128         my $n = shift @ARGV;
1129
1130         badusage "for each EXTRA-UPS-NAME need EXTRA-UPS-COMMITISH"
1131             unless @ARGV && $ARGV[0] !~ m{^-};
1132
1133         my $c = git_rev_parse shift @ARGV;
1134         die unless $n =~ m/^$extra_orig_namepart_re$/;
1135         $newpiece->($n, New => $c);
1136     }
1137
1138     # now we need to investigate the branch this generates the
1139     # laundered version but we don't switch to it yet
1140     my $old_head = get_head();
1141     my ($old_laundered_tip,$old_bw,$old_anchor) = walk $old_head;
1142
1143     my $old_bw_cl = classify $old_bw;
1144     my $old_anchor_cl = classify $old_anchor;
1145     my $old_upstream;
1146     if (!$old_anchor_cl->{OrigParents}) {
1147         snag 'anchor-treated',
1148             'old anchor is recognised due to --anchor, cannot check upstream';
1149     } else {
1150         $old_upstream = parsecommit
1151             $old_anchor_cl->{OrigParents}[0]{CommitId};
1152         $piece->('', Old => $old_upstream->{CommitId});
1153     }
1154
1155     if ($old_upstream && $old_upstream->{Msg} =~ m{^\[git-debrebase }m) {
1156         if ($old_upstream->{Msg} =~
1157  m{^\[git-debrebase upstream-combine \.((?: $extra_orig_namepart_re)+)\:.*\]$}m
1158            ) {
1159             my @oldpieces = ('', split / /, $1);
1160             my $parentix = -1 + scalar @{ $old_upstream->{Parents} };
1161             foreach my $i (0..$#oldpieces) {
1162                 my $n = $oldpieces[$i];
1163                 $piece->($n, Old => $old_upstream->{CommitId}.'^'.$parentix);
1164             }
1165         } else {
1166             snag 'upstream-confusing',
1167                 "previous upstream $old_upstream->{CommitId} is from".
1168                " git-debrebase but not an \`upstream-combine' commit";
1169         }
1170     }
1171
1172     foreach my $pc (values %pieces) {
1173         if (!$old_upstream) {
1174             # we have complained already
1175         } elsif (!$pc->{Old}) {
1176             snag 'upstream-new-piece',
1177                 "introducing upstream piece \`$pc->{Name}'";
1178         } elsif (!$pc->{New}) {
1179             snag 'upstream-rm-piece',
1180                 "dropping upstream piece \`$pc->{Name}'";
1181         } elsif (!is_fast_fwd $pc->{Old}, $pc->{New}) {
1182             snag 'upstream-not-ff',
1183                 "not fast forward: $pc->{Name} $pc->{Old}..$pc->{New}";
1184         }
1185     }
1186
1187     printdebug "%pieces = ", (dd \%pieces), "\n";
1188     printdebug "\@newpieces = ", (dd \@newpieces), "\n";
1189
1190     snags_maybe_bail();
1191
1192     my $new_bw;
1193
1194     fresh_workarea();
1195     in_workarea sub {
1196         my @upstream_merge_parents;
1197
1198         if (!any_snags()) {
1199             push @upstream_merge_parents, $old_upstream->{CommitId};
1200         }
1201
1202         foreach my $pc (@newpieces) { # always has '' first
1203             if ($pc->{Name}) {
1204                 read_tree_subdir $pc->{Name}, $pc->{New};
1205             } else {
1206                 runcmd @git, qw(read-tree), $pc->{New};
1207             }
1208             push @upstream_merge_parents, $pc->{New};
1209         }
1210
1211         # index now contains the new upstream
1212
1213         if (@newpieces > 1) {
1214             # need to make the upstream subtree merge commit
1215             $new_upstream = make_commit \@upstream_merge_parents,
1216                 [ "Combine upstreams for $new_upstream_version",
1217  ("[git-debrebase upstream-combine . ".
1218  (join " ", map { $_->{Name} } @newpieces[1..$#newpieces]).
1219  ": new upstream]"),
1220                 ];
1221         }
1222
1223         # $new_upstream is either the single upstream commit, or the
1224         # combined commit we just made.  Either way it will be the
1225         # "upstream" parent of the anchor merge.
1226
1227         read_tree_subdir 'debian', "$old_bw:debian";
1228
1229         # index now contains the anchor merge contents
1230         $new_bw = make_commit [ $old_bw, $new_upstream ],
1231             [ "Update to upstream $new_upstream_version",
1232  "[git-debrebase anchor: new upstream $new_upstream_version, merge]",
1233             ];
1234
1235         # Now we have to add a changelog stanza so the Debian version
1236         # is right.
1237         die if unlink "debian";
1238         die $! unless $!==ENOENT or $!==ENOTEMPTY;
1239         unlink "debian/changelog" or $!==ENOENT or die $!;
1240         mkdir "debian" or die $!;
1241         open CN, ">", "debian/changelog" or die $!;
1242         my $oldclog = git_cat_file ":debian/changelog";
1243         $oldclog =~ m/^($package_re) \(\S+\) / or
1244             fail "cannot parse old changelog to get package name";
1245         my $p = $1;
1246         print CN <<END, $oldclog or die $!;
1247 $p ($new_version) UNRELEASED; urgency=medium
1248
1249   * Update to new upstream version $new_upstream_version.
1250
1251  --
1252
1253 END
1254         close CN or die $!;
1255         runcmd @git, qw(update-index --add --replace), 'debian/changelog';
1256
1257         # Now we have the final new breakwater branch in the index
1258         $new_bw = make_commit [ $new_bw ],
1259             [ "Update changelog for new upstream $new_upstream_version",
1260               "[git-debrebase: new upstream $new_upstream_version, changelog]",
1261             ];
1262     };
1263
1264     # we have constructed the new breakwater. we now need to commit to
1265     # the laundering output, because git-rebase can't easily be made
1266     # to make a replay list which is based on some other branch
1267
1268     update_head_postlaunder $old_head, $old_laundered_tip,
1269         'launder for new upstream';
1270
1271     my @cmd = (@git, qw(rebase --onto), $new_bw, $old_bw, @ARGV);
1272     runcmd @cmd;
1273     # now it's for the user to sort out
1274 }
1275
1276 sub cmd_record_ffq_prev () {
1277     badusage "no arguments allowed" if @ARGV;
1278     my ($status, $msg) = record_ffq_prev_deferred();
1279     if ($status eq 'exists' && $opt_noop_ok) {
1280         print "Previous head already recorded\n" or die $!;
1281     } elsif ($status eq 'deferred') {
1282         run_deferred_updates 'record-ffq-prev';
1283     } else {
1284         fail "Could not preserve: $msg";
1285     }
1286 }
1287
1288 sub cmd_anchor () {
1289     badusage "no arguments allowed" if @ARGV;
1290     my ($anchor, $bw) = keycommits +(git_rev_parse 'HEAD'), 0,0;
1291     print "$bw\n" or die $!;
1292 }
1293
1294 sub cmd_breakwater () {
1295     badusage "no arguments allowed" if @ARGV;
1296     my ($anchor, $bw) = keycommits +(git_rev_parse 'HEAD'), 0,0;
1297     print "$bw\n" or die $!;
1298 }
1299
1300 sub cmd_stitch () {
1301     my $prose = 'stitch';
1302     GetOptions('prose=s', \$prose) or die badusage("bad options to stitch");
1303     badusage "no arguments allowed" if @ARGV;
1304     do_stitch($prose);
1305 }
1306
1307 sub cmd_conclude () {
1308     badusage "no arguments allowed" if @ARGV;
1309     do_launder_head 'launder for conclude';
1310     do_stitch 'conclude';
1311 }
1312
1313 sub cmd_convert_from_gbp () {
1314     badusage "needs 1 optional argument, the upstream git rev"
1315         unless @ARGV<=1;
1316     my ($upstream_spec) = @ARGV;
1317     $upstream_spec //= 'refs/heads/upstream';
1318     my $upstream = git_rev_parse $upstream_spec;
1319     my $old_head = get_head();
1320
1321     my $upsdiff = get_differs $upstream, $old_head;
1322     if ($upsdiff & D_UPS) {
1323         runcmd @git, qw(--no-pager diff),
1324             $upstream, $old_head,
1325             qw( -- :!/debian :/);
1326  fail "upstream ($upstream_spec) and HEAD are not identical in upstream files";
1327     }
1328
1329     if (!is_fast_fwd $upstream, $old_head) {
1330         snag 'upstream-not-ancestor',
1331             "upstream ($upstream) is not an ancestor of HEAD";
1332     } else {
1333         my $wrong = cmdoutput
1334             (@git, qw(rev-list --ancestry-path), "$upstream..HEAD",
1335              qw(-- :/ :!/debian));
1336         if (length $wrong) {
1337             snag 'unexpected-upstream-changes',
1338                 "history between upstream ($upstream) and HEAD contains direct changes to upstream files - are you sure this is a gbp (patches-unapplied) branch?";
1339             print STDERR "list expected changes with:  git log --stat --ancestry-path $upstream_spec..HEAD -- :/ ':!/debian'\n";
1340         }
1341     }
1342
1343     if ((git_cat_file "$upstream:debian")[0] ne 'missing') {
1344         snag 'upstream-has-debian',
1345             "upstream ($upstream) contains debian/ directory";
1346     }
1347
1348     snags_maybe_bail();
1349
1350     my $work;
1351
1352     fresh_workarea();
1353     in_workarea sub {
1354         runcmd @git, qw(checkout -q -b gdr-internal), $old_head;
1355         # make a branch out of the patch queue - we'll want this in a mo
1356         runcmd qw(gbp pq import);
1357         # strip the patches out
1358         runcmd @git, qw(checkout -q gdr-internal~0);
1359         rm_subdir_cached 'debian/patches';
1360         $work = make_commit ['HEAD'], [
1361  'git-debrebase convert-from-gbp: drop patches from tree',
1362  'Delete debian/patches, as part of converting to git-debrebase format.',
1363  '[git-debrebase convert-from-gbp: drop patches from tree]'
1364                               ];
1365         # make the anchor merge
1366         # the tree is already exactly right
1367         $work = make_commit [$work, $upstream], [
1368  'git-debrebase import: declare upstream',
1369  'First breakwater merge.',
1370  '[git-debrebase anchor: declare upstream]'
1371                               ];
1372
1373         # rebase the patch queue onto the new breakwater
1374         runcmd @git, qw(reset --quiet --hard patch-queue/gdr-internal);
1375         runcmd @git, qw(rebase --quiet --onto), $work, qw(gdr-internal);
1376         $work = git_rev_parse 'HEAD';
1377     };
1378
1379     update_head_checkout $old_head, $work, 'convert-from-gbp';
1380 }
1381
1382 sub cmd_convert_to_gbp () {
1383     badusage "no arguments allowed" if @ARGV;
1384     my $head = get_head();
1385     my (undef, undef, undef, $ffq, $gdrlast) = ffq_prev_branchinfo();
1386     my ($anchor, $bw) = keycommits $head, 0;
1387     fresh_workarea();
1388     my $out;
1389     in_workarea sub {
1390         runcmd @git, qw(checkout -q -b bw), $bw;
1391         runcmd @git, qw(checkout -q -b patch-queue/bw), $head;
1392         runcmd qw(gbp pq export);
1393         runcmd @git, qw(add debian/patches);
1394         $out = make_commit ['HEAD'], [
1395             'Commit patch queue (converted from git-debrebase format)',
1396             '[git-debrebase convert-to-gbp: commit patches]',
1397         ];
1398     };
1399     if (defined $ffq) {
1400         push @deferred_updates, "delete $ffq";
1401         push @deferred_updates, "delete $gdrlast";
1402     }
1403     update_head_checkout $head, $out, "convert to gbp (v0)";
1404     print <<END or die $!;
1405 git-debrebase: converted to git-buildpackage branch format
1406 git-debrebase: WARNING: do not now run "git-debrebase" any more
1407 git-debrebase: WARNING: doing so would drop all upstream patches!
1408 END
1409 }
1410
1411 sub cmd_downstream_rebase_launder_v0 () {
1412     badusage "needs 1 argument, the baseline" unless @ARGV==1;
1413     my ($base) = @ARGV;
1414     $base = git_rev_parse $base;
1415     my $old_head = get_head();
1416     my $current = $old_head;
1417     my $topmost_keep;
1418     for (;;) {
1419         if ($current eq $base) {
1420             $topmost_keep //= $current;
1421             print " $current BASE stop\n";
1422             last;
1423         }
1424         my $cl = classify $current;
1425         print " $current $cl->{Type}";
1426         my $keep = 0;
1427         my $p0 = $cl->{Parents}[0]{CommitId};
1428         my $next;
1429         if ($cl->{Type} eq 'Pseudomerge') {
1430             print " ^".($cl->{Contributor}{Ix}+1);
1431             $next = $cl->{Contributor}{CommitId};
1432         } elsif ($cl->{Type} eq 'AddPatches' or
1433                  $cl->{Type} eq 'Changelog') {
1434             print " strip";
1435             $next = $p0;
1436         } else {
1437             print " keep";
1438             $next = $p0;
1439             $keep = 1;
1440         }
1441         print "\n";
1442         if ($keep) {
1443             $topmost_keep //= $current;
1444         } else {
1445             die "to-be stripped changes not on top of the branch\n"
1446                 if $topmost_keep;
1447         }
1448         $current = $next;
1449     }
1450     if ($topmost_keep eq $old_head) {
1451         print "unchanged\n";
1452     } else {
1453         print "updating to $topmost_keep\n";
1454         update_head_checkout
1455             $old_head, $topmost_keep,
1456             'downstream-rebase-launder-v0';
1457     }
1458 }
1459
1460 GetOptions("D+" => \$debuglevel,
1461            'noop-ok', => \$opt_noop_ok,
1462            'f=s' => \@snag_force_opts,
1463            'anchor=s' => \@opt_anchors,
1464            'force!') or die badusage "bad options\n";
1465 initdebug('git-debrebase ');
1466 enabledebug if $debuglevel;
1467
1468 my $toplevel = cmdoutput @git, qw(rev-parse --show-toplevel);
1469 chdir $toplevel or die "chdir $toplevel: $!";
1470
1471 $rd = fresh_playground "$playprefix/misc";
1472
1473 @opt_anchors = map { git_rev_parse $_ } @opt_anchors;
1474
1475 if (!@ARGV || $ARGV[0] =~ m{^-}) {
1476     defaultcmd_rebase();
1477 } else {
1478     my $cmd = shift @ARGV;
1479     my $cmdfn = $cmd;
1480     $cmdfn =~ y/-/_/;
1481     $cmdfn = ${*::}{"cmd_$cmdfn"};
1482
1483     $cmdfn or badusage "unknown git-debrebase sub-operation $cmd";
1484     $cmdfn->();
1485 }