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 END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
  22 use Debian::Dgit::GDR;
  23 use Debian::Dgit::ExitStatus;
  24
  25 use strict;
  26
  27 use Debian::Dgit qw(:DEFAULT :playground);
  28 setup_sigwarn();
  29
  30 use Memoize;
  31 use Carp;
  32 use POSIX;
  33 use Data::Dumper;
  34 use Getopt::Long qw(:config posix_default gnu_compat bundling);
  35 use Dpkg::Version;
  36 use File::FnMatch qw(:fnmatch);
  37 use File::Copy;
  38
  39 our ($opt_force, $opt_noop_ok, @opt_anchors);
  40 our ($opt_defaultcmd_interactive);
  41
  42 our $us = qw(git-debrebase);
  43
  44 $|=1;
  45
  46 sub badusage ($) {
  47     my ($m) = @_;
  48     print STDERR "bad usage: $m\n";
  49     finish 8;
  50 }
  51
  52 sub cfg ($;$) {
  53     my ($k, $optional) = @_;
  54     local $/ = "\0";
  55     my @cmd = qw(git config -z);
  56     push @cmd, qw(--get-all) if wantarray;
  57     push @cmd, $k;
  58     my $out = cmdoutput_errok @cmd;
  59     if (!defined $out) {
  60         fail "missing required git config $k" unless $optional;
  61         return ();
  62     }
  63     my @l = split /\0/, $out;
  64     return wantarray ? @l : $l[0];
  65 }
  66
  67 memoize('cfg');
  68
  69 sub dd ($) {
  70     my ($v) = @_;
  71     my $dd = new Data::Dumper [ $v ];
  72     Terse $dd 1; Indent $dd 0; Useqq $dd 1;
  73     return Dump $dd;
  74 }
  75
  76 sub get_commit ($) {
  77     my ($objid) = @_;
  78     my $data = (git_cat_file $objid, 'commit');
  79     $data =~ m/(?<=\n)\n/ or die "$objid ($data) ?";
  80     return ($`,$');
  81 }
  82
  83 sub D_UPS ()      { 0x02; } # upstream files
  84 sub D_PAT_ADD ()  { 0x04; } # debian/patches/ extra patches at end
  85 sub D_PAT_OTH ()  { 0x08; } # debian/patches other changes
  86 sub D_DEB_CLOG () { 0x10; } # debian/ (not patches/ or changelog)
  87 sub D_DEB_OTH ()  { 0x20; } # debian/changelog
  88 sub DS_DEB ()     { D_DEB_CLOG | D_DEB_OTH; } # debian/ (not patches/)
  89
  90 our $playprefix = 'debrebase';
  91 our $rd;
  92 our $workarea;
  93
  94 our @git = qw(git);
  95
  96 sub in_workarea ($) {
  97     my ($sub) = @_;
  98     changedir $workarea;
  99     my $r = eval { $sub->(); };
 100     { local $@; changedir $maindir; }
 101     die $@ if $@;
 102 }
 103
 104 sub fresh_workarea () {
 105     $workarea = fresh_playground "$playprefix/work";
 106     in_workarea sub { playtree_setup };
 107 }
 108
 109 our $snags_forced = 0;
 110 our $snags_tripped = 0;
 111 our $snags_summarised = 0;
 112 our @deferred_updates;
 113 our @deferred_update_messages;
 114
 115 sub all_snags_summarised () {
 116     $snags_forced + $snags_tripped == $snags_summarised;
 117 }
 118 sub run_deferred_updates ($) {
 119     my ($mrest) = @_;
 120
 121     confess 'dangerous internal error' unless all_snags_summarised();
 122
 123     my @upd_cmd = (git_update_ref_cmd "debrebase: $mrest", qw(--stdin));
 124     debugcmd '>|', @upd_cmd;
 125     open U, "|-", @upd_cmd or die $!;
 126     foreach (@deferred_updates) {
 127         printdebug ">= ", $_, "\n";
 128         print U $_, "\n" or die $!;
 129     }
 130     printdebug ">\$\n";
 131     close U or failedcmd @upd_cmd;
 132
 133     print $_, "\n" foreach @deferred_update_messages;
 134
 135     @deferred_updates = ();
 136     @deferred_update_messages = ();
 137 }
 138
 139 sub get_differs ($$) {
 140     my ($x,$y) = @_;
 141     # This resembles quiltify_trees_differ, in dgit, a bit.
 142     # But we don't care about modes, or dpkg-source-unrepresentable
 143     # changes, and we don't need the plethora of different modes.
 144     # Conversely we need to distinguish different kinds of changes to
 145     # debian/ and debian/patches/.
 146
 147     my $differs = 0;
 148
 149     my $rundiff = sub {
 150         my ($opts, $limits, $fn) = @_;
 151         my @cmd = (@git, qw(diff-tree -z --no-renames));
 152         push @cmd, @$opts;
 153         push @cmd, "$_:" foreach $x, $y;
 154         push @cmd, '--', @$limits;
 155         my $diffs = cmdoutput @cmd;
 156         foreach (split /\0/, $diffs) { $fn->(); }
 157     };
 158
 159     $rundiff->([qw(--name-only)], [], sub {
 160         $differs |= $_ eq 'debian' ? DS_DEB : D_UPS;
 161     });
 162
 163     if ($differs & DS_DEB) {
 164         $differs &= ~DS_DEB;
 165         $rundiff->([qw(--name-only -r)], [qw(debian)], sub {
 166             $differs |=
 167                 m{^debian/patches/}      ? D_PAT_OTH  :
 168                 $_ eq 'debian/changelog' ? D_DEB_CLOG :
 169                                            D_DEB_OTH;
 170         });
 171         die "mysterious debian changes $x..$y"
 172             unless $differs & (D_PAT_OTH|DS_DEB);
 173     }
 174
 175     if ($differs & D_PAT_OTH) {
 176         my $mode;
 177         $differs &= ~D_PAT_OTH;
 178         my $pat_oth = sub {
 179             $differs |= D_PAT_OTH;
 180             no warnings qw(exiting);  last;
 181         };
 182         $rundiff->([qw(--name-status -r)], [qw(debian/patches/)], sub {
 183             no warnings qw(exiting);
 184             if (!defined $mode) {
 185                 $mode = $_;  next;
 186             }
 187             die unless s{^debian/patches/}{};
 188             my $ok;
 189             if ($mode eq 'A' && !m/\.series$/s) {
 190                 $ok = 1;
 191             } elsif ($mode eq 'M' && $_ eq 'series') {
 192                 my $x_s = (git_cat_file "$x:debian/patches/series", 'blob');
 193                 my $y_s = (git_cat_file "$y:debian/patches/series", 'blob');
 194                 chomp $x_s;  $x_s .= "\n";
 195                 $ok = $x_s eq substr($y_s, 0, length $x_s);
 196             } else {
 197                 # nope
 198             }
 199             $mode = undef;
 200             $differs |= $ok ? D_PAT_ADD : D_PAT_OTH;
 201         });
 202         die "mysterious debian/patches changes $x..$y"
 203             unless $differs & (D_PAT_ADD|D_PAT_OTH);
 204     }
 205
 206     printdebug sprintf "get_differs %s, %s = %#x\n", $x, $y, $differs;
 207
 208     return $differs;
 209 }
 210
 211 sub commit_pr_info ($) {
 212     my ($r) = @_;
 213     return Data::Dumper->dump([$r], [qw(commit)]);
 214 }
 215
 216 sub calculate_committer_authline () {
 217     my $c = cmdoutput @git, qw(commit-tree --no-gpg-sign -m),
 218         'DUMMY COMMIT (git-debrebase)', "HEAD:";
 219     my ($h,$m) = get_commit $c;
 220     $h =~ m/^committer .*$/m or confess "($h) ?";
 221     return $&;
 222 }
 223
 224 sub rm_subdir_cached ($) {
 225     my ($subdir) = @_;
 226     runcmd @git, qw(rm --quiet -rf --cached --ignore-unmatch), $subdir;
 227 }
 228
 229 sub read_tree_subdir ($$) {
 230     my ($subdir, $new_tree_object) = @_;
 231     rm_subdir_cached $subdir;
 232     runcmd @git, qw(read-tree), "--prefix=$subdir/", $new_tree_object;
 233 }
 234
 235 sub make_commit ($$) {
 236     my ($parents, $message_paras) = @_;
 237     my $tree = cmdoutput @git, qw(write-tree);
 238     my @cmd = (@git, qw(commit-tree), $tree);
 239     push @cmd, qw(-p), $_ foreach @$parents;
 240     push @cmd, qw(-m), $_ foreach @$message_paras;
 241     return cmdoutput @cmd;
 242 }
 243
 244 our @snag_force_opts;
 245 sub snag ($$;@) {
 246     my ($tag,$msg) = @_; # ignores extra args, for benefit of keycommits
 247     if (grep { $_ eq $tag } @snag_force_opts) {
 248         $snags_forced++;
 249         print STDERR "git-debrebase: snag ignored (-f$tag): $msg\n";
 250     } else {
 251         $snags_tripped++;
 252         print STDERR "git-debrebase: snag detected (-f$tag): $msg\n";
 253     }
 254 }
 255
 256 # Important: all mainline code must call snags_maybe_bail after
 257 # any point where snag might be called, but before making changes
 258 # (eg before any call to run_deferred_updates).  snags_maybe_bail
 259 # may be called more than once if necessary (but this is not ideal
 260 # because then the messages about number of snags may be confusing).
 261 sub snags_maybe_bail () {
 262     return if all_snags_summarised();
 263     if ($snags_forced) {
 264         printf STDERR
 265             "%s: snags: %d overriden by individual -f options\n",
 266             $us, $snags_forced;
 267     }
 268     if ($snags_tripped) {
 269         if ($opt_force) {
 270             printf STDERR
 271                 "%s: snags: %d overriden by global --force\n",
 272                 $us, $snags_tripped;
 273         } else {
 274             fail sprintf
 275   "%s: snags: %d blocker(s) (you could -f<tag>, or --force)",
 276                 $us, $snags_tripped;
 277         }
 278     }
 279     $snags_summarised = $snags_forced + $snags_tripped;
 280 }
 281 sub snags_maybe_bail_early () {
 282     # useful to bail out early without doing a lot of work;
 283     # not a substitute for snags_maybe_bail.
 284     snags_maybe_bail() if $snags_tripped && !$opt_force;
 285 }
 286 sub any_snags () {
 287     return $snags_forced || $snags_tripped;
 288 }
 289
 290 # classify returns an info hash like this
 291 #   CommitId => $objid
 292 #   Hdr => # commit headers, including 1 final newline
 293 #   Msg => # commit message (so one newline is dropped)
 294 #   Tree => $treeobjid
 295 #   Type => (see below)
 296 #   Parents = [ {
 297 #       Ix => $index # ie 0, 1, 2, ...
 298 #       CommitId
 299 #       Differs => return value from get_differs
 300 #       IsOrigin
 301 #       IsDggitImport => 'orig' 'tarball' 'unpatched' 'package' (as from dgit)
 302 #     } ...]
 303 #   NewMsg => # commit message, but with any [dgit import ...] edited
 304 #             # to say "[was: ...]"
 305 #
 306 # Types:
 307 #   Packaging
 308 #   Changelog
 309 #   Upstream
 310 #   AddPatches
 311 #   Mixed
 312 #
 313 #   Pseudomerge
 314 #     has additional entres in classification result
 315 #       Overwritten = [ subset of Parents ]
 316 #       Contributor = $the_remaining_Parent
 317 #
 318 #   DgitImportUnpatched
 319 #     has additional entry in classification result
 320 #       OrigParents = [ subset of Parents ]
 321 #
 322 #   Anchor
 323 #     has additional entry in classification result
 324 #       OrigParents = [ subset of Parents ]  # singleton list
 325 #
 326 #   TreatAsAnchor
 327 #
 328 #   BreakwaterStart
 329 #
 330 #   Unknown
 331 #     has additional entry in classification result
 332 #       Why => "prose"
 333
 334 sub parsecommit ($;$) {
 335     my ($objid, $p_ref) = @_;
 336     # => hash with                   CommitId Hdr Msg Tree Parents
 337     #    Parents entries have only   Ix CommitId
 338     #    $p_ref, if provided, must be [] and is used as a base for Parents
 339
 340     $p_ref //= [];
 341     die if @$p_ref;
 342
 343     my ($h,$m) = get_commit $objid;
 344
 345     my ($t) = $h =~ m/^tree (\w+)$/m or die $objid;
 346     my (@ph) = $h =~ m/^parent (\w+)$/mg;
 347
 348     my $r = {
 349         CommitId => $objid,
 350         Hdr => $h,
 351         Msg => $m,
 352         Tree => $t,
 353         Parents => $p_ref,
 354     };
 355
 356     foreach my $ph (@ph) {
 357         push @$p_ref, {
 358             Ix => scalar @$p_ref,
 359             CommitId => $ph,
 360         };
 361     }
 362
 363     return $r;
 364 }
 365
 366 sub classify ($) {
 367     my ($objid) = @_;
 368
 369     my @p;
 370     my $r = parsecommit($objid, \@p);
 371     my $t = $r->{Tree};
 372
 373     foreach my $p (@p) {
 374         $p->{Differs} = (get_differs $p->{CommitId}, $t),
 375     }
 376
 377     printdebug "classify $objid \$t=$t \@p",
 378         (map { sprintf " %s/%#x", $_->{CommitId}, $_->{Differs} } @p),
 379         "\n";
 380
 381     my $classify = sub {
 382         my ($type, @rest) = @_;
 383         $r = { %$r, Type => $type, @rest };
 384         if ($debuglevel) {
 385             printdebug " = $type ".(dd $r)."\n";
 386         }
 387         return $r;
 388     };
 389     my $unknown = sub {
 390         my ($why) = @_;
 391         $r = { %$r, Type => qw(Unknown), Why => $why };
 392         printdebug " ** Unknown\n";
 393         return $r;
 394     };
 395
 396     if (grep { $_ eq $objid } @opt_anchors) {
 397         return $classify->('TreatAsAnchor');
 398     }
 399
 400     my @identical = grep { !$_->{Differs} } @p;
 401     my ($stype, $series) = git_cat_file "$t:debian/patches/series";
 402     my $haspatches = $stype ne 'missing' && $series =~ m/^\s*[^#\n\t ]/m;
 403
 404     if ($r->{Msg} =~ m{^\[git-debrebase anchor.*\]$}m) {
 405         # multi-orig upstreams are represented with an anchor merge
 406         # from a single upstream commit which combines the orig tarballs
 407
 408         # Every anchor tagged this way must be a merge.
 409         # We are relying on the
 410         #     [git-debrebase anchor: ...]
 411         # commit message annotation in "declare" anchor merges (which
 412         # do not have any upstream changes), to distinguish those
 413         # anchor merges from ordinary pseudomerges (which we might
 414         # just try to strip).
 415         #
 416         # However, the user is going to be doing git-rebase a lot.  We
 417         # really don't want them to rewrite an anchor commit.
 418         # git-rebase trips up on merges, so that is a useful safety
 419         # catch.
 420         #
 421         # BreakwaterStart commits are also anchors in the terminology
 422         # of git-debrebase(5), but they are untagged (and always
 423         # manually generated).
 424         #
 425         # We cannot not tolerate any tagged linear commit (ie,
 426         # BreakwaterStart commits tagged `[anchor:') because such a
 427         # thing could result from an erroneous linearising raw git
 428         # rebase of a merge anchor.  That would represent a corruption
 429         # of the branch. and we want to detect and reject the results
 430         # of such corruption before it makes it out anywhere.  If we
 431         # reject it here then we avoid making the pseudomerge which
 432         # would be needed to push it.
 433
 434         my $badanchor = sub { $unknown->("git-debrebase \`anchor' but @_"); };
 435         @p == 2 or return $badanchor->("has other than two parents");
 436         $haspatches and return $badanchor->("contains debian/patches");
 437
 438         # How to decide about l/r ordering of anchors ?  git
 439         # --topo-order prefers to expand 2nd parent first.  There's
 440         # already an easy rune to look for debian/ history anyway (git log
 441         # debian/) so debian breakwater branch should be 1st parent; that
 442         # way also there's also an easy rune to look for the upstream
 443         # patches (--topo-order).
 444
 445         # Also this makes --first-parent be slightly more likely to
 446         # be useful - it makes it provide a linearised breakwater history.
 447
 448         # Of course one can say somthing like
 449         #  gitk -- ':/' ':!/debian'
 450         # to get _just_ the commits touching upstream files, and by
 451         # the TREESAME logic in git-rev-list this will leave the
 452         # breakwater into upstream at the first anchor.  But that
 453         # doesn't report debian/ changes at all.
 454
 455         # Other observations about gitk: by default, gitk seems to
 456         # produce output in a different order to git-rev-list.  I
 457         # can't seem to find this documented anywhere.  gitk
 458         # --date-order DTRT.  But, gitk always seems to put the
 459         # parents from left to right, in order, so it's easy to see
 460         # which way round a pseudomerge is.
 461
 462         $p[0]{IsOrigin} and $badanchor->("is an origin commit");
 463         $p[1]{Differs} & ~DS_DEB and
 464             $badanchor->("upstream files differ from left parent");
 465         $p[0]{Differs} & ~D_UPS and
 466             $badanchor->("debian/ differs from right parent");
 467
 468         return $classify->(qw(Anchor),
 469                            OrigParents => [ $p[1] ]);
 470     }
 471
 472     if (@p == 1) {
 473         my $d = $r->{Parents}[0]{Differs};
 474         if ($d == D_PAT_ADD) {
 475             return $classify->(qw(AddPatches));
 476         } elsif ($d & (D_PAT_ADD|D_PAT_OTH)) {
 477             return $unknown->("edits debian/patches");
 478         } elsif ($d & DS_DEB and !($d & ~DS_DEB)) {
 479             my ($ty,$dummy) = git_cat_file "$p[0]{CommitId}:debian";
 480             if ($ty eq 'tree') {
 481                 if ($d == D_DEB_CLOG) {
 482                     return $classify->(qw(Changelog));
 483                 } else {
 484                     return $classify->(qw(Packaging));
 485                 }
 486             } elsif ($ty eq 'missing') {
 487                 return $classify->(qw(BreakwaterStart));
 488             } else {
 489                 return $unknown->("parent's debian is not a directory");
 490             }
 491         } elsif ($d == D_UPS) {
 492             return $classify->(qw(Upstream));
 493         } elsif ($d & DS_DEB and $d & D_UPS and !($d & ~(DS_DEB|D_UPS))) {
 494             return $classify->(qw(Mixed));
 495         } elsif ($d == 0) {
 496             return $unknown->("no changes");
 497         } else {
 498             confess "internal error $objid ?";
 499         }
 500     }
 501     if (!@p) {
 502         return $unknown->("origin commit");
 503     }
 504
 505     if (@p == 2 && @identical == 1) {
 506         my @overwritten = grep { $_->{Differs} } @p;
 507         confess "internal error $objid ?" unless @overwritten==1;
 508         return $classify->(qw(Pseudomerge),
 509                            Overwritten => [ $overwritten[0] ],
 510                            Contributor => $identical[0]);
 511     }
 512     if (@p == 2 && @identical == 2) {
 513         my $get_t = sub {
 514             my ($ph,$pm) = get_commit $_[0]{CommitId};
 515             $ph =~ m/^committer .* (\d+) [-+]\d+$/m or die "$_->{CommitId} ?";
 516             $1;
 517         };
 518         my @bytime = @p;
 519         my $order = $get_t->($bytime[0]) <=> $get_t->($bytime[1]);
 520         if ($order > 0) { # newer first
 521         } elsif ($order < 0) {
 522             @bytime = reverse @bytime;
 523         } else {
 524             # same age, default to order made by -s ours
 525             # that is, commit was made by someone who preferred L
 526         }
 527         return $classify->(qw(Pseudomerge),
 528                            SubType => qw(Ambiguous),
 529                            Contributor => $bytime[0],
 530                            Overwritten => [ $bytime[1] ]);
 531     }
 532     foreach my $p (@p) {
 533         my ($p_h, $p_m) = get_commit $p->{CommitId};
 534         $p->{IsOrigin} = $p_h !~ m/^parent \w+$/m;
 535         ($p->{IsDgitImport},) = $p_m =~ m/^\[dgit import ([0-9a-z]+) .*\]$/m;
 536     }
 537     my @orig_ps = grep { ($_->{IsDgitImport}//'X') eq 'orig' } @p;
 538     my $m2 = $r->{Msg};
 539     if (!(grep { !$_->{IsOrigin} } @p) and
 540         (@orig_ps >= @p - 1) and
 541         $m2 =~ s{^\[(dgit import unpatched .*)\]$}{[was: $1]}m) {
 542         $r->{NewMsg} = $m2;
 543         return $classify->(qw(DgitImportUnpatched),
 544                            OrigParents => \@orig_ps);
 545     }
 546
 547     return $unknown->("complex merge");
 548 }
 549
 550 sub keycommits ($;$$$$) {
 551     my ($head, $furniture, $unclean, $trouble, $fatal) = @_;
 552     # => ($anchor, $breakwater)
 553
 554     # $unclean->("unclean-$tagsfx", $msg, $cl)
 555     # $furniture->("unclean-$tagsfx", $msg, $cl)
 556     # $dgitimport->("unclean-$tagsfx", $msg, $cl))
 557     #   is callled for each situation or commit that
 558     #   wouldn't be found in a laundered branch
 559     # $furniture is for furniture commits such as might be found on an
 560     #   interchange branch (pseudomerge, d/patches, changelog)
 561     # $trouble is for things whnich prevent the return of
 562     #   anchor and breakwater information; if that is ignored,
 563     #   then keycommits returns (undef, undef) instead.
 564     # $fatal is for unprocessable commits, and should normally cause
 565     #    a failure.  If ignored, agaion, (undef, undef) is returned.
 566     #
 567     # If a callback is undef, fail is called instead.
 568     # If a callback is defined but false, the situation is ignored.
 569     # Callbacks may say:
 570     #   no warnings qw(exiting); last;
 571     # if the answer is no longer wanted.
 572
 573     my ($anchor, $breakwater);
 574     my $clogonly;
 575     my $cl;
 576     $fatal //= sub { fail $_[2]; };
 577     my $x = sub {
 578         my ($cb, $tagsfx, $mainwhy, $xwhy) = @_;
 579         my $why = $mainwhy.$xwhy;
 580         my $m = "branch needs laundering (run git-debrebase): $why";
 581         fail $m unless defined $cb;
 582         return unless $cb;
 583         $cb->("unclean-$tagsfx", $why, $cl, $mainwhy);
 584     };
 585     for (;;) {
 586         $cl = classify $head;
 587         my $ty = $cl->{Type};
 588         if ($ty eq 'Packaging') {
 589             $breakwater //= $clogonly;
 590             $breakwater //= $head;
 591         } elsif ($ty eq 'Changelog') {
 592             # this is going to count as the tip of the breakwater
 593             # only if it has no upstream stuff before it
 594             $clogonly //= $head;
 595         } elsif ($ty eq 'Anchor' or
 596                  $ty eq 'TreatAsAnchor' or
 597                  $ty eq 'BreakwaterStart') {
 598             $anchor = $head;
 599             $breakwater //= $clogonly;
 600             $breakwater //= $head;
 601             last;
 602         } elsif ($ty eq 'Upstream') {
 603             $x->($unclean, 'ordering',
 604  "packaging change ($breakwater) follows upstream change"," (eg $head)")
 605                 if defined $breakwater;
 606             $clogonly = undef;
 607             $breakwater = undef;
 608         } elsif ($ty eq 'Mixed') {
 609             $x->($unclean, 'mixed',
 610                  "found mixed upstream/packaging commit"," ($head)");
 611             $clogonly = undef;
 612             $breakwater = undef;
 613         } elsif ($ty eq 'Pseudomerge' or
 614                  $ty eq 'AddPatches') {
 615             $x->($furniture, (lc $ty),
 616                  "found interchange bureaucracy commit ($ty)"," ($head)");
 617         } elsif ($ty eq 'DgitImportUnpatched') {
 618             $x->($trouble, 'dgitimport',
 619                  "found dgit dsc import ($head)");
 620             return (undef,undef);
 621         } else {
 622             $x->($fatal, 'unprocessable',
 623                  "found unprocessable commit, cannot cope: $cl->{Why}",
 624                  " ($head)");
 625             return (undef,undef);
 626         }
 627         $head = $cl->{Parents}[0]{CommitId};
 628     }
 629     return ($anchor, $breakwater);
 630 }
 631
 632 sub walk ($;$$);
 633 sub walk ($;$$) {
 634     my ($input,
 635         $nogenerate,$report) = @_;
 636     # => ($tip, $breakwater_tip, $last_anchor)
 637     # (or nothing, if $nogenerate)
 638
 639     printdebug "*** WALK $input ".($nogenerate//0)." ".($report//'-')."\n";
 640
 641     # go through commits backwards
 642     # we generate two lists of commits to apply:
 643     # breakwater branch and upstream patches
 644     my (@brw_cl, @upp_cl, @processed);
 645     my %found;
 646     my $upp_limit;
 647     my @pseudomerges;
 648
 649     my $cl;
 650     my $xmsg = sub {
 651         my ($prose, $info) = @_;
 652         my $ms = $cl->{Msg};
 653         chomp $ms;
 654         $info //= '';
 655         $ms .= "\n\n[git-debrebase$info: $prose]\n";
 656         return (Msg => $ms);
 657     };
 658     my $rewrite_from_here = sub {
 659         my ($cl) = @_;
 660         my $sp_cl = { SpecialMethod => 'StartRewrite' };
 661         push @$cl, $sp_cl;
 662         push @processed, $sp_cl;
 663     };
 664     my $cur = $input;
 665
 666     my $prdelim = "";
 667     my $prprdelim = sub { print $report $prdelim if $report; $prdelim=""; };
 668
 669     my $prline = sub {
 670         return unless $report;
 671         print $report $prdelim, @_;
 672         $prdelim = "\n";
 673     };
 674
 675     my $bomb = sub { # usage: return $bomb->();
 676         print $report " Unprocessable" if $report;
 677         print $report " ($cl->{Why})" if $report && defined $cl->{Why};
 678         $prprdelim->();
 679         if ($nogenerate) {
 680             return (undef,undef);
 681         }
 682         die "commit $cur: Cannot cope with this commit (d.".
 683             (join ' ', map { sprintf "%#x", $_->{Differs} }
 684              @{ $cl->{Parents} }).
 685             (defined $cl->{Why} ? "; $cl->{Why}": '').
 686                  ")";
 687     };
 688
 689     my $build;
 690     my $breakwater;
 691
 692     my $build_start = sub {
 693         my ($msg, $parent) = @_;
 694         $prline->(" $msg");
 695         $build = $parent;
 696         no warnings qw(exiting); last;
 697     };
 698
 699     my $last_anchor;
 700
 701     for (;;) {
 702         $cl = classify $cur;
 703         my $ty = $cl->{Type};
 704         my $st = $cl->{SubType};
 705         $prline->("$cl->{CommitId} $cl->{Type}");
 706         $found{$ty. ( defined($st) ? "-$st" : '' )}++;
 707         push @processed, $cl;
 708         my $p0 = @{ $cl->{Parents} }==1 ? $cl->{Parents}[0]{CommitId} : undef;
 709         if ($ty eq 'AddPatches') {
 710             $cur = $p0;
 711             $rewrite_from_here->(\@upp_cl);
 712             next;
 713         } elsif ($ty eq 'Packaging' or $ty eq 'Changelog') {
 714             push @brw_cl, $cl;
 715             $cur = $p0;
 716             next;
 717         } elsif ($ty eq 'BreakwaterStart') {
 718             $last_anchor = $cur;
 719             $build_start->('FirstPackaging', $cur);
 720         } elsif ($ty eq 'Upstream') {
 721             push @upp_cl, $cl;
 722             $cur = $p0;
 723             next;
 724         } elsif ($ty eq 'Mixed') {
 725             my $queue = sub {
 726                 my ($q, $wh) = @_;
 727                 my $cls = { %$cl, $xmsg->("split mixed commit: $wh part") };
 728                 push @$q, $cls;
 729             };
 730             $queue->(\@brw_cl, "debian");
 731             $queue->(\@upp_cl, "upstream");
 732             $rewrite_from_here->(\@brw_cl);
 733             $cur = $p0;
 734             next;
 735         } elsif ($ty eq 'Pseudomerge') {
 736             my $contrib = $cl->{Contributor}{CommitId};
 737             print $report " Contributor=$contrib" if $report;
 738             push @pseudomerges, $cl;
 739             $rewrite_from_here->(\@upp_cl);
 740             $cur = $contrib;
 741             next;
 742         } elsif ($ty eq 'Anchor' or $ty eq 'TreatAsAnchor') {
 743             $last_anchor = $cur;
 744             $build_start->("Anchor", $cur);
 745         } elsif ($ty eq 'DgitImportUnpatched') {
 746             my $pm = $pseudomerges[-1];
 747             if (defined $pm) {
 748                 # To an extent, this is heuristic.  Imports don't have
 749                 # a useful history of the debian/ branch.  We assume
 750                 # that the first pseudomerge after an import has a
 751                 # useful history of debian/, and ignore the histories
 752                 # from later pseudomerges.  Often the first pseudomerge
 753                 # will be the dgit import of the upload to the actual
 754                 # suite intended by the non-dgit NMUer, and later
 755                 # pseudomerges may represent in-archive copies.
 756                 my $ovwrs = $pm->{Overwritten};
 757                 printf $report " PM=%s \@Overwr:%d",
 758                     $pm->{CommitId}, (scalar @$ovwrs)
 759                     if $report;
 760                 if (@$ovwrs != 1) {
 761                     printdebug "*** WALK BOMB DgitImportUnpatched\n";
 762                     return $bomb->();
 763                 }
 764                 my $ovwr = $ovwrs->[0]{CommitId};
 765                 printf $report " Overwr=%s", $ovwr if $report;
 766                 # This import has a tree which is just like a
 767                 # breakwater tree, but it has the wrong history.  It
 768                 # ought to have the previous breakwater (which the
 769                 # pseudomerge overwrote) as an ancestor.  That will
 770                 # make the history of the debian/ files correct.  As
 771                 # for the upstream version: either it's the same as
 772                 # was ovewritten (ie, same as the previous
 773                 # breakwater), in which case that history is precisely
 774                 # right; or, otherwise, it was a non-gitish upload of a
 775                 # new upstream version.  We can tell these apart by
 776                 # looking at the tree of the supposed upstream.
 777                 push @brw_cl, {
 778                     %$cl,
 779                     SpecialMethod => 'DgitImportDebianUpdate',
 780                     $xmsg->("convert dgit import: debian changes")
 781                 }, {
 782                     %$cl,
 783                     SpecialMethod => 'DgitImportUpstreamUpdate',
 784                     $xmsg->("convert dgit import: upstream update",
 785                             " anchor")
 786                 };
 787                 $prline->(" Import");
 788                 $rewrite_from_here->(\@brw_cl);
 789                 $upp_limit //= $#upp_cl; # further, deeper, patches discarded
 790                 $cur = $ovwr;
 791                 next;
 792             } else {
 793                 # Everything is from this import.  This kind of import
 794                 # is already in valid breakwater format, with the
 795                 # patches as commits.
 796                 printf $report " NoPM" if $report;
 797                 # last thing we processed will have been the first patch,
 798                 # if there is one; which is fine, so no need to rewrite
 799                 # on account of this import
 800                 $build_start->("ImportOrigin", $cur);
 801             }
 802             die "$ty ?";
 803         } else {
 804             printdebug "*** WALK BOMB unrecognised\n";
 805             return $bomb->();
 806         }
 807     }
 808     $prprdelim->();
 809
 810     printdebug "*** WALK prep done cur=$cur".
 811         " brw $#brw_cl upp $#upp_cl proc $#processed pm $#pseudomerges\n";
 812
 813     return if $nogenerate;
 814
 815     # Now we build it back up again
 816
 817     fresh_workarea();
 818
 819     my $rewriting = 0;
 820
 821     my $read_tree_debian = sub {
 822         my ($treeish) = @_;
 823         read_tree_subdir 'debian', "$treeish:debian";
 824         rm_subdir_cached 'debian/patches';
 825     };
 826     my $read_tree_upstream = sub {
 827         my ($treeish) = @_;
 828         runcmd @git, qw(read-tree), $treeish;
 829         $read_tree_debian->($build);
 830     };
 831
 832     $#upp_cl = $upp_limit if defined $upp_limit;
 833
 834     my $committer_authline = calculate_committer_authline();
 835
 836     printdebug "WALK REBUILD $build ".(scalar @processed)."\n";
 837
 838     confess "internal error" unless $build eq (pop @processed)->{CommitId};
 839
 840     in_workarea sub {
 841         mkdir $rd or $!==EEXIST or die $!;
 842         my $current_method;
 843         runcmd @git, qw(read-tree), $build;
 844         foreach my $cl (qw(Debian), (reverse @brw_cl),
 845                         { SpecialMethod => 'RecordBreakwaterTip' },
 846                         qw(Upstream), (reverse @upp_cl)) {
 847             if (!ref $cl) {
 848                 $current_method = $cl;
 849                 next;
 850             }
 851             my $method = $cl->{SpecialMethod} // $current_method;
 852             my @parents = ($build);
 853             my $cltree = $cl->{CommitId};
 854             printdebug "WALK BUILD ".($cltree//'undef').
 855                 " $method (rewriting=$rewriting)\n";
 856             if ($method eq 'Debian') {
 857                 $read_tree_debian->($cltree);
 858             } elsif ($method eq 'Upstream') {
 859                 $read_tree_upstream->($cltree);
 860             } elsif ($method eq 'StartRewrite') {
 861                 $rewriting = 1;
 862                 next;
 863             } elsif ($method eq 'RecordBreakwaterTip') {
 864                 $breakwater = $build;
 865                 next;
 866             } elsif ($method eq 'DgitImportDebianUpdate') {
 867                 $read_tree_debian->($cltree);
 868             } elsif ($method eq 'DgitImportUpstreamUpdate') {
 869                 confess unless $rewriting;
 870                 my $differs = (get_differs $build, $cltree);
 871                 next unless $differs & D_UPS;
 872                 $read_tree_upstream->($cltree);
 873                 push @parents, map { $_->{CommitId} } @{ $cl->{OrigParents} };
 874             } else {
 875                 confess "$method ?";
 876             }
 877             if (!$rewriting) {
 878                 my $procd = (pop @processed) // 'UNDEF';
 879                 if ($cl ne $procd) {
 880                     $rewriting = 1;
 881                     printdebug "WALK REWRITING NOW cl=$cl procd=$procd\n";
 882                 }
 883             }
 884             my $newtree = cmdoutput @git, qw(write-tree);
 885             my $ch = $cl->{Hdr};
 886             $ch =~ s{^tree .*}{tree $newtree}m or confess "$ch ?";
 887             $ch =~ s{^parent .*\n}{}mg;
 888             $ch =~ s{(?=^author)}{
 889                 join '', map { "parent $_\n" } @parents
 890             }me or confess "$ch ?";
 891             if ($rewriting) {
 892                 $ch =~ s{^committer .*$}{$committer_authline}m
 893                     or confess "$ch ?";
 894             }
 895             my $cf = "$rd/m$rewriting";
 896             open CD, ">", $cf or die $!;
 897             print CD $ch, "\n", $cl->{Msg} or die $!;
 898             close CD or die $!;
 899             my @cmd = (@git, qw(hash-object));
 900             push @cmd, qw(-w) if $rewriting;
 901             push @cmd, qw(-t commit), $cf;
 902             my $newcommit = cmdoutput @cmd;
 903             confess "$ch ?" unless $rewriting or $newcommit eq $cl->{CommitId};
 904             $build = $newcommit;
 905             if (grep { $method eq $_ } qw(DgitImportUpstreamUpdate)) {
 906                 $last_anchor = $cur;
 907             }
 908         }
 909     };
 910
 911     my $final_check = get_differs $build, $input;
 912     die sprintf "internal error %#x %s %s", $final_check, $build, $input
 913         if $final_check & ~D_PAT_ADD;
 914
 915     my @r = ($build, $breakwater, $last_anchor);
 916     printdebug "*** WALK RETURN @r\n";
 917     return @r
 918 }
 919
 920 sub get_head () {
 921     git_check_unmodified();
 922     return git_rev_parse qw(HEAD);
 923 }
 924
 925 sub update_head ($$$) {
 926     my ($old, $new, $mrest) = @_;
 927     push @deferred_updates, "update HEAD $new $old";
 928     run_deferred_updates $mrest;
 929 }
 930
 931 sub update_head_checkout ($$$) {
 932     my ($old, $new, $mrest) = @_;
 933     update_head $old, $new, $mrest;
 934     runcmd @git, qw(reset --hard);
 935 }
 936
 937 sub update_head_postlaunder ($$$) {
 938     my ($old, $tip, $reflogmsg) = @_;
 939     return if $tip eq $old;
 940     print "git-debrebase: laundered (head was $old)\n";
 941     update_head $old, $tip, $reflogmsg;
 942     # no tree changes except debian/patches
 943     runcmd @git, qw(rm --quiet --ignore-unmatch -rf debian/patches);
 944 }
 945
 946 sub do_launder_head ($) {
 947     my ($reflogmsg) = @_;
 948     my $old = get_head();
 949     record_ffq_auto();
 950     my ($tip,$breakwater) = walk $old;
 951     snags_maybe_bail();
 952     update_head_postlaunder $old, $tip, $reflogmsg;
 953     return ($tip,$breakwater);
 954 }
 955
 956 sub cmd_launder_v0 () {
 957     badusage "no arguments to launder-v0 allowed" if @ARGV;
 958     my $old = get_head();
 959     my ($tip,$breakwater,$last_anchor) = walk $old;
 960     update_head_postlaunder $old, $tip, 'launder';
 961     printf "# breakwater tip\n%s\n", $breakwater;
 962     printf "# working tip\n%s\n", $tip;
 963     printf "# last anchor\n%s\n", $last_anchor;
 964 }
 965
 966 sub defaultcmd_rebase () {
 967     push @ARGV, @{ $opt_defaultcmd_interactive // [] };
 968     my ($tip,$breakwater) = do_launder_head 'launder for rebase';
 969     runcmd @git, qw(rebase), @ARGV, $breakwater if @ARGV;
 970 }
 971
 972 sub cmd_analyse () {
 973     die if ($ARGV[0]//'') =~ m/^-/;
 974     badusage "too many arguments to analyse" if @ARGV>1;
 975     my ($old) = @ARGV;
 976     if (defined $old) {
 977         $old = git_rev_parse $old;
 978     } else {
 979         $old = git_rev_parse 'HEAD';
 980     }
 981     my ($dummy,$breakwater) = walk $old, 1,*STDOUT;
 982     STDOUT->error and die $!;
 983 }
 984
 985 sub ffq_prev_branchinfo () {
 986     my $current = git_get_symref();
 987     return gdr_ffq_prev_branchinfo($current);
 988 }
 989
 990 sub ffq_check ($;$$) {
 991     # calls $ff and/or $notff zero or more times
 992     # then returns either (status,message) where status is
 993     #    exists
 994     #    detached
 995     #    weird-symref
 996     #    notbranch
 997     # or (undef,undef, $ffq_prev,$gdrlast)
 998     # $ff and $notff are called like this:
 999     #   $ff->("message for stdout\n");
1000     #   $notff->('snag-name', $message);
1001     # normally $currentval should be HEAD
1002     my ($currentval, $ff, $notff) =@_;
1003
1004     $ff //= sub { print $_[0] or die $!; };
1005     $notff //= \&snag;
1006
1007     my ($status, $message, $current, $ffq_prev, $gdrlast)
1008         = ffq_prev_branchinfo();
1009     return ($status, $message) unless $status eq 'branch';
1010
1011     my $exists = git_get_ref $ffq_prev;
1012     return ('exists',"$ffq_prev already exists") if $exists;
1013
1014     return ('not-branch', 'HEAD symref is not to refs/heads/')
1015         unless $current =~ m{^refs/heads/};
1016     my $branch = $';
1017
1018     my @check_specs = split /\;/, (cfg "branch.$branch.ffq-ffrefs",1) // '*';
1019     my %checked;
1020
1021     printdebug "ffq check_specs @check_specs\n";
1022
1023     my $check = sub {
1024         my ($lrref, $desc) = @_;
1025         printdebug "ffq might check $lrref ($desc)\n";
1026         my $invert;
1027         for my $chk (@check_specs) {
1028             my $glob = $chk;
1029             $invert = $glob =~ s{^[!^]}{};
1030             last if fnmatch $glob, $lrref;
1031         }
1032         return if $invert;
1033         my $lrval = git_get_ref $lrref;
1034         return unless length $lrval;
1035
1036         if (is_fast_fwd $lrval, $currentval) {
1037             $ff->("OK, you are ahead of $lrref\n");
1038             $checked{$lrref} = 1;
1039         } elsif (is_fast_fwd $currentval, $lrval) {
1040             $checked{$lrref} = -1;
1041             $notff->('behind', "you are behind $lrref, divergence risk");
1042         } else {
1043             $checked{$lrref} = -1;
1044             $notff->('diverged', "you have diverged from $lrref");
1045         }
1046     };
1047
1048     my $merge = cfg "branch.$branch.merge",1;
1049     if (defined $merge and $merge =~ m{^refs/heads/}) {
1050         my $rhs = $';
1051         printdebug "ffq merge $rhs\n";
1052         my $check_remote = sub {
1053             my ($remote, $desc) = @_;
1054             printdebug "ffq check_remote ".($remote//'undef')." $desc\n";
1055             return unless defined $remote;
1056             $check->("refs/remotes/$remote/$rhs", $desc);
1057         };
1058         $check_remote->((scalar cfg "branch.$branch.remote",1),
1059                         'remote fetch/merge branch');
1060         $check_remote->((scalar cfg "branch.$branch.pushRemote",1) //
1061                         (scalar cfg "branch.$branch.pushDefault",1),
1062                         'remote push branch');
1063     }
1064     if ($branch =~ m{^dgit/}) {
1065         $check->("refs/remotes/dgit/$branch", 'remote dgit branch');
1066     } elsif ($branch =~ m{^master$}) {
1067         $check->("refs/remotes/dgit/dgit/sid", 'remote dgit branch for sid');
1068     }
1069     return (undef, undef, $ffq_prev, $gdrlast);
1070 }
1071
1072 sub record_ffq_prev_deferred () {
1073     # => ('status', "message")
1074     # 'status' may be
1075     #    deferred          message is undef
1076     #    exists
1077     #    detached
1078     #    weird-symref
1079     #    notbranch
1080     # if not ff from some branch we should be ff from, is an snag
1081     # if "deferred", will have added something about that to
1082     #   @deferred_update_messages, and also maybe printed (already)
1083     #   some messages about ff checks
1084     my $currentval = get_head();
1085
1086     my ($status,$message, $ffq_prev,$gdrlast) = ffq_check $currentval;
1087     return ($status,$message) if defined $status;
1088
1089     snags_maybe_bail();
1090
1091     push @deferred_updates, "update $ffq_prev $currentval $git_null_obj";
1092     push @deferred_updates, "delete $gdrlast";
1093     push @deferred_update_messages, "Recorded current head for preservation";
1094     return ('deferred', undef);
1095 }
1096
1097 sub record_ffq_auto () {
1098     my ($status, $message) = record_ffq_prev_deferred();
1099     if ($status eq 'deferred' || $status eq 'exists') {
1100     } else {
1101         snag $status, "could not record ffq-prev: $message";
1102         snags_maybe_bail();
1103     }
1104 }
1105
1106 sub ffq_prev_info () {
1107     # => ($ffq_prev, $gdrlast, $ffq_prev_commitish)
1108     my ($status, $message, $current, $ffq_prev, $gdrlast)
1109         = ffq_prev_branchinfo();
1110     if ($status ne 'branch') {
1111         snag $status, "could not check ffq-prev: $message";
1112         snags_maybe_bail();
1113     }
1114     my $ffq_prev_commitish = $ffq_prev && git_get_ref $ffq_prev;
1115     return ($ffq_prev, $gdrlast, $ffq_prev_commitish);
1116 }
1117
1118 sub stitch ($$$$$) {
1119     my ($old_head, $ffq_prev, $gdrlast, $ffq_prev_commitish, $prose) = @_;
1120
1121     push @deferred_updates, "delete $ffq_prev $ffq_prev_commitish";
1122
1123     if (is_fast_fwd $old_head, $ffq_prev_commitish) {
1124         my $differs = get_differs $old_head, $ffq_prev_commitish;
1125         unless ($differs & ~D_PAT_ADD) {
1126             # ffq-prev is ahead of us, and the only tree changes it has
1127             # are possibly addition of things in debian/patches/.
1128             # Just wind forwards rather than making a pointless pseudomerge.
1129             push @deferred_updates,
1130                 "update $gdrlast $ffq_prev_commitish $git_null_obj";
1131             update_head_checkout $old_head, $ffq_prev_commitish,
1132                 "stitch (fast forward)";
1133             return;
1134         }
1135     }
1136     fresh_workarea();
1137     # We make pseudomerges with L as the contributing parent.
1138     # This makes git rev-list --first-parent work properly.
1139     my $new_head = make_commit [ $old_head, $ffq_prev ], [
1140         'Declare fast forward / record previous work',
1141         "[git-debrebase pseudomerge: $prose]",
1142     ];
1143     push @deferred_updates, "update $gdrlast $new_head $git_null_obj";
1144     update_head $old_head, $new_head, "stitch: $prose";
1145 }
1146
1147 sub do_stitch ($;$) {
1148     my ($prose, $unclean) = @_;
1149
1150     my ($ffq_prev, $gdrlast, $ffq_prev_commitish) = ffq_prev_info();
1151     if (!$ffq_prev_commitish) {
1152         fail "No ffq-prev to stitch." unless $opt_noop_ok;
1153         return;
1154     }
1155     my $dangling_head = get_head();
1156
1157     keycommits $dangling_head, $unclean,$unclean,$unclean;
1158     snags_maybe_bail();
1159
1160     stitch($dangling_head, $ffq_prev, $gdrlast, $ffq_prev_commitish, $prose);
1161 }
1162
1163 sub cmd_new_upstream () {
1164     # automatically and unconditionally launders before rebasing
1165     # if rebase --abort is used, laundering has still been done
1166
1167     my %pieces;
1168
1169     badusage "need NEW-VERSION [UPS-COMMITTISH]" unless @ARGV >= 1;
1170
1171     # parse args - low commitment
1172     my $spec_version = shift @ARGV;
1173     my $new_version = (new Dpkg::Version $spec_version, check => 1);
1174     if ($new_version->is_native()) {
1175         $new_version = (new Dpkg::Version "$spec_version-1", check => 1);
1176     }
1177     my $new_upstream_version = $new_version->version();
1178
1179     my $new_upstream = shift @ARGV;
1180     if (!defined $new_upstream) {
1181         my @tried;
1182         # todo: at some point maybe use git-deborig to do this
1183         foreach my $tagpfx ('', 'v', 'upstream/') {
1184             my $tag = $tagpfx.(dep14_version_mangle $new_upstream_version);
1185             $new_upstream = git_get_ref "refs/tags/$tag";
1186             last if length $new_upstream;
1187             push @tried, $tag;
1188         }
1189         if (!length $new_upstream) {
1190             fail "Could not determine appropriate upstream commitish.\n".
1191                 " (Tried these tags: @tried)\n".
1192                 " Check version, and specify upstream commitish explicitly.";
1193         }
1194     }
1195     $new_upstream = git_rev_parse $new_upstream;
1196
1197     record_ffq_auto();
1198
1199     my $piece = sub {
1200         my ($n, @x) = @_; # may be ''
1201         my $pc = $pieces{$n} //= {
1202             Name => $n,
1203             Desc => ($n ? "upstream piece \`$n'" : "upstream (main piece"),
1204         };
1205         while (my $k = shift @x) { $pc->{$k} = shift @x; }
1206         $pc;
1207     };
1208
1209     my @newpieces;
1210     my $newpiece = sub {
1211         my ($n, @x) = @_; # may be ''
1212         my $pc = $piece->($n, @x, NewIx => (scalar @newpieces));
1213         push @newpieces, $pc;
1214     };
1215
1216     $newpiece->('',
1217         OldIx => 0,
1218         New => $new_upstream,
1219     );
1220     while (@ARGV && $ARGV[0] !~ m{^-}) {
1221         my $n = shift @ARGV;
1222
1223         badusage "for each EXTRA-UPS-NAME need EXTRA-UPS-COMMITISH"
1224             unless @ARGV && $ARGV[0] !~ m{^-};
1225
1226         my $c = git_rev_parse shift @ARGV;
1227         die unless $n =~ m/^$extra_orig_namepart_re$/;
1228         $newpiece->($n, New => $c);
1229     }
1230
1231     # now we need to investigate the branch this generates the
1232     # laundered version but we don't switch to it yet
1233     my $old_head = get_head();
1234     my ($old_laundered_tip,$old_bw,$old_anchor) = walk $old_head;
1235
1236     my $old_bw_cl = classify $old_bw;
1237     my $old_anchor_cl = classify $old_anchor;
1238     my $old_upstream;
1239     if (!$old_anchor_cl->{OrigParents}) {
1240         snag 'anchor-treated',
1241             'old anchor is recognised due to --anchor, cannot check upstream';
1242     } else {
1243         $old_upstream = parsecommit
1244             $old_anchor_cl->{OrigParents}[0]{CommitId};
1245         $piece->('', Old => $old_upstream->{CommitId});
1246     }
1247
1248     if ($old_upstream && $old_upstream->{Msg} =~ m{^\[git-debrebase }m) {
1249         if ($old_upstream->{Msg} =~
1250  m{^\[git-debrebase upstream-combine (\.(?: $extra_orig_namepart_re)+)\:.*\]$}m
1251            ) {
1252             my @oldpieces = (split / /, $1);
1253             my $old_n_parents = scalar @{ $old_upstream->{Parents} };
1254             if ($old_n_parents != @oldpieces &&
1255                 $old_n_parents != @oldpieces + 1) {
1256                 snag 'upstream-confusing', sprintf
1257                     "previous upstream combine %s".
1258                     " mentions %d pieces (each implying one parent)".
1259                     " but has %d parents".
1260                     " (one per piece plus maybe a previous combine)",
1261                     $old_upstream->{CommitId},
1262                     (scalar @oldpieces),
1263                     $old_n_parents;
1264             } elsif ($oldpieces[0] ne '.') {
1265                 snag 'upstream-confusing', sprintf
1266                     "previous upstream combine %s".
1267                     " first piece is not \`.'",
1268                     $oldpieces[0];
1269             } else {
1270                 $oldpieces[0] = '';
1271                 foreach my $i (0..$#oldpieces) {
1272                     my $n = $oldpieces[$i];
1273                     my $hat = 1 + $i + ($old_n_parents - @oldpieces);
1274                     $piece->($n, Old => $old_upstream->{CommitId}.'^'.$hat);
1275                 }
1276             }
1277         } else {
1278             snag 'upstream-confusing',
1279                 "previous upstream $old_upstream->{CommitId} is from".
1280                " git-debrebase but not an \`upstream-combine' commit";
1281         }
1282     }
1283
1284     foreach my $pc (values %pieces) {
1285         if (!$old_upstream) {
1286             # we have complained already
1287         } elsif (!$pc->{Old}) {
1288             snag 'upstream-new-piece',
1289                 "introducing upstream piece \`$pc->{Name}'";
1290         } elsif (!$pc->{New}) {
1291             snag 'upstream-rm-piece',
1292                 "dropping upstream piece \`$pc->{Name}'";
1293         } elsif (!is_fast_fwd $pc->{Old}, $pc->{New}) {
1294             snag 'upstream-not-ff',
1295                 "not fast forward: $pc->{Name} $pc->{Old}..$pc->{New}";
1296         }
1297     }
1298
1299     printdebug "%pieces = ", (dd \%pieces), "\n";
1300     printdebug "\@newpieces = ", (dd \@newpieces), "\n";
1301
1302     snags_maybe_bail();
1303
1304     my $new_bw;
1305
1306     fresh_workarea();
1307     in_workarea sub {
1308         my @upstream_merge_parents;
1309
1310         if (!any_snags()) {
1311             push @upstream_merge_parents, $old_upstream->{CommitId};
1312         }
1313
1314         foreach my $pc (@newpieces) { # always has '' first
1315             if ($pc->{Name}) {
1316                 read_tree_subdir $pc->{Name}, $pc->{New};
1317             } else {
1318                 runcmd @git, qw(read-tree), $pc->{New};
1319             }
1320             push @upstream_merge_parents, $pc->{New};
1321         }
1322
1323         # index now contains the new upstream
1324
1325         if (@newpieces > 1) {
1326             # need to make the upstream subtree merge commit
1327             $new_upstream = make_commit \@upstream_merge_parents,
1328                 [ "Combine upstreams for $new_upstream_version",
1329  ("[git-debrebase upstream-combine . ".
1330  (join " ", map { $_->{Name} } @newpieces[1..$#newpieces]).
1331  ": new upstream]"),
1332                 ];
1333         }
1334
1335         # $new_upstream is either the single upstream commit, or the
1336         # combined commit we just made.  Either way it will be the
1337         # "upstream" parent of the anchor merge.
1338
1339         read_tree_subdir 'debian', "$old_bw:debian";
1340
1341         # index now contains the anchor merge contents
1342         $new_bw = make_commit [ $old_bw, $new_upstream ],
1343             [ "Update to upstream $new_upstream_version",
1344  "[git-debrebase anchor: new upstream $new_upstream_version, merge]",
1345             ];
1346
1347         my $clogsignoff = cmdoutput qw(git show),
1348             '--pretty=format:%an <%ae>  %aD',
1349             $new_bw;
1350
1351         # Now we have to add a changelog stanza so the Debian version
1352         # is right.
1353         die if unlink "debian";
1354         die $! unless $!==ENOENT or $!==ENOTEMPTY;
1355         unlink "debian/changelog" or $!==ENOENT or die $!;
1356         mkdir "debian" or die $!;
1357         open CN, ">", "debian/changelog" or die $!;
1358         my $oldclog = git_cat_file ":debian/changelog";
1359         $oldclog =~ m/^($package_re) \(\S+\) / or
1360             fail "cannot parse old changelog to get package name";
1361         my $p = $1;
1362         print CN <<END, $oldclog or die $!;
1363 $p ($new_version) UNRELEASED; urgency=medium
1364
1365   * Update to new upstream version $new_upstream_version.
1366
1367  -- $clogsignoff
1368
1369 END
1370         close CN or die $!;
1371         runcmd @git, qw(update-index --add --replace), 'debian/changelog';
1372
1373         # Now we have the final new breakwater branch in the index
1374         $new_bw = make_commit [ $new_bw ],
1375             [ "Update changelog for new upstream $new_upstream_version",
1376               "[git-debrebase: new upstream $new_upstream_version, changelog]",
1377             ];
1378     };
1379
1380     # we have constructed the new breakwater. we now need to commit to
1381     # the laundering output, because git-rebase can't easily be made
1382     # to make a replay list which is based on some other branch
1383
1384     update_head_postlaunder $old_head, $old_laundered_tip,
1385         'launder for new upstream';
1386
1387     my @cmd = (@git, qw(rebase --onto), $new_bw, $old_bw, @ARGV);
1388     local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg
1389         "debrebase new-upstream $new_version: rebase";
1390     runcmd @cmd;
1391     # now it's for the user to sort out
1392 }
1393
1394 sub cmd_record_ffq_prev () {
1395     badusage "no arguments allowed" if @ARGV;
1396     my ($status, $msg) = record_ffq_prev_deferred();
1397     if ($status eq 'exists' && $opt_noop_ok) {
1398         print "Previous head already recorded\n" or die $!;
1399     } elsif ($status eq 'deferred') {
1400         run_deferred_updates 'record-ffq-prev';
1401     } else {
1402         fail "Could not preserve: $msg";
1403     }
1404 }
1405
1406 sub cmd_anchor () {
1407     badusage "no arguments allowed" if @ARGV;
1408     my ($anchor, $bw) = keycommits +(git_rev_parse 'HEAD'), 0,0;
1409     print "$bw\n" or die $!;
1410 }
1411
1412 sub cmd_breakwater () {
1413     badusage "no arguments allowed" if @ARGV;
1414     my ($anchor, $bw) = keycommits +(git_rev_parse 'HEAD'), 0,0;
1415     print "$bw\n" or die $!;
1416 }
1417
1418 sub cmd_status () {
1419     badusage "no arguments allowed" if @ARGV;
1420
1421     # todo: gdr status should print divergence info
1422     # todo: gdr status should print upstream component(s) info
1423     # todo: gdr should leave/maintain some refs with this kind of info ?
1424
1425     my $oldest = { Badness => 0 };
1426     my $newest;
1427     my $note = sub {
1428         my ($badness, $ourmsg, $snagname, $dummy, $cl, $kcmsg) = @_;
1429         if ($oldest->{Badness} < $badness) {
1430             $oldest = $newest = undef;
1431         }
1432         $oldest = {
1433                    Badness => $badness,
1434                    CommitId => $cl->{CommitId},
1435                    OurMsg => $ourmsg,
1436                    KcMsg => $kcmsg,
1437                   };
1438         $newest //= $oldest;
1439     };
1440     my ($anchor, $bw) = keycommits +(git_rev_parse 'HEAD'),
1441         sub { $note->(1, 'branch contains furniture (not laundered)', @_); },
1442         sub { $note->(2, 'branch is unlaundered', @_); },
1443         sub { $note->(3, 'branch needs laundering', @_); },
1444         sub { $note->(4, 'branch not in git-debrebase form', @_); };
1445
1446     my $prcommitinfo = sub {
1447         my ($cid) = @_;
1448         flush STDOUT or die $!;
1449         runcmd @git, qw(--no-pager log -n1),
1450             '--pretty=format:    %h %s%n',
1451             $cid;
1452     };
1453
1454     print "current branch contents, in git-debrebase terms:\n";
1455     if (!$oldest->{Badness}) {
1456         print "  branch is laundered\n";
1457     } else {
1458         print "  $oldest->{OurMsg}\n";
1459         my $printed = '';
1460         foreach my $info ($oldest, $newest) {
1461             my $cid = $info->{CommitId};
1462             next if $cid eq $printed;
1463             $printed = $cid;
1464             print "  $info->{KcMsg}\n";
1465             $prcommitinfo->($cid);
1466         }
1467     }
1468
1469     my $prab = sub {
1470         my ($cid, $what) = @_;
1471         if (!defined $cid) {
1472             print "  $what is not well-defined\n";
1473         } else {
1474             print "  $what\n";
1475             $prcommitinfo->($cid);
1476         }
1477     };
1478     print "key git-debrebase commits:\n";
1479     $prab->($anchor, 'anchor');
1480     $prab->($bw, 'breakwater');
1481
1482     my ($ffqstatus, $ffq_msg, $current, $ffq_prev, $gdrlast) =
1483         ffq_prev_branchinfo();
1484
1485     print "branch and ref status, in git-debrebase terms:\n";
1486     if ($ffq_msg) {
1487         print "  $ffq_msg\n";
1488     } else {
1489         $ffq_prev = git_get_ref $ffq_prev;
1490         $gdrlast = git_get_ref $gdrlast;
1491         if ($ffq_prev) {
1492             print "  unstitched; previous tip was:\n";
1493             $prcommitinfo->($ffq_prev);
1494         } elsif (!$gdrlast) {
1495             print "  stitched? (no record of git-debrebase work)\n";
1496         } elsif (is_fast_fwd $gdrlast, 'HEAD') {
1497             print "  stitched\n";
1498         } else {
1499             print "  not git-debrebase (diverged since last stitch)\n"
1500         }
1501     }
1502 }
1503
1504 sub cmd_stitch () {
1505     my $prose = 'stitch';
1506     GetOptions('prose=s', \$prose) or badusage("bad options to stitch");
1507     badusage "no arguments allowed" if @ARGV;
1508     do_stitch $prose, 0;
1509 }
1510 sub cmd_prepush () { cmd_stitch(); }
1511
1512 sub cmd_quick () {
1513     badusage "no arguments allowed" if @ARGV;
1514     do_launder_head 'launder for git-debrebase quick';
1515     do_stitch 'quick';
1516 }
1517
1518 sub cmd_conclude () {
1519     my ($ffq_prev, $gdrlast, $ffq_prev_commitish) = ffq_prev_info();
1520     if (!$ffq_prev_commitish) {
1521         fail "No ongoing git-debrebase session." unless $opt_noop_ok;
1522         return;
1523     }
1524     my $dangling_head = get_head();
1525
1526     badusage "no arguments allowed" if @ARGV;
1527     do_launder_head 'launder for git-debrebase quick';
1528     do_stitch 'quick';
1529 }
1530
1531 sub make_patches_staged ($) {
1532     my ($head) = @_;
1533     # Produces the patches that would result from $head if it were
1534     # laundered.
1535     my ($secret_head, $secret_bw, $last_anchor) = walk $head;
1536     fresh_workarea();
1537     in_workarea sub {
1538         runcmd @git, qw(checkout -q -b bw), $secret_bw;
1539         runcmd @git, qw(checkout -q -b patch-queue/bw), $secret_head;
1540         my @gbp_cmd = (qw(gbp pq export));
1541         my $r = system shell_cmd 'exec >../gbp-pq-err 2>&1', @gbp_cmd;
1542         if ($r) {
1543             { local ($!,$?); copy('../gbp-pq-err', \*STDERR); }
1544             failedcmd @gbp_cmd;
1545         }
1546         runcmd @git, qw(add -f debian/patches);
1547     };
1548 }
1549
1550 sub make_patches ($) {
1551     my ($head) = @_;
1552     keycommits $head, 0, \&snag;
1553     make_patches_staged $head;
1554     my $out;
1555     in_workarea sub {
1556         my $ptree = cmdoutput @git, qw(write-tree --prefix=debian/patches/);
1557         runcmd @git, qw(read-tree), $head;
1558         read_tree_subdir 'debian/patches', $ptree;
1559         $out = make_commit [$head], [
1560             'Commit patch queue (exported by git-debrebase)',
1561             '[git-debrebase: export and commit patches]',
1562         ];
1563     };
1564     return $out;
1565 }
1566
1567 sub cmd_make_patches () {
1568     my $opt_quiet_would_amend;
1569     GetOptions('quiet-would-amend!', \$opt_quiet_would_amend)
1570         or badusage("bad options to make-patches");
1571     badusage "no arguments allowed" if @ARGV;
1572     my $old_head = get_head();
1573     my $new = make_patches $old_head;
1574     my $d = get_differs $old_head, $new;
1575     if ($d == 0) {
1576         fail "No (more) patches to export." unless $opt_noop_ok;
1577         return;
1578     } elsif ($d == D_PAT_ADD) {
1579         snags_maybe_bail();
1580         update_head_checkout $old_head, $new, 'make-patches';
1581     } else {
1582         print STDERR failmsg
1583             "Patch export produced patch amendments".
1584             " (abandoned output commit $new).".
1585             "  Try laundering first."
1586             unless $opt_quiet_would_amend;
1587         finish 7;
1588     }
1589 }
1590
1591 sub cmd_convert_from_gbp () {
1592     badusage "needs 1 optional argument, the upstream git rev"
1593         unless @ARGV<=1;
1594     my ($upstream_spec) = @ARGV;
1595     $upstream_spec //= 'refs/heads/upstream';
1596     my $upstream = git_rev_parse $upstream_spec;
1597     my $old_head = get_head();
1598
1599     my $upsdiff = get_differs $upstream, $old_head;
1600     if ($upsdiff & D_UPS) {
1601         runcmd @git, qw(--no-pager diff),
1602             $upstream, $old_head,
1603             qw( -- :!/debian :/);
1604  fail "upstream ($upstream_spec) and HEAD are not identical in upstream files";
1605     }
1606
1607     if (!is_fast_fwd $upstream, $old_head) {
1608         snag 'upstream-not-ancestor',
1609             "upstream ($upstream) is not an ancestor of HEAD";
1610     } else {
1611         my $wrong = cmdoutput
1612             (@git, qw(rev-list --ancestry-path), "$upstream..HEAD",
1613              qw(-- :/ :!/debian));
1614         if (length $wrong) {
1615             snag 'unexpected-upstream-changes',
1616                 "history between upstream ($upstream) and HEAD contains direct changes to upstream files - are you sure this is a gbp (patches-unapplied) branch?";
1617             print STDERR "list expected changes with:  git log --stat --ancestry-path $upstream_spec..HEAD -- :/ ':!/debian'\n";
1618         }
1619     }
1620
1621     if ((git_cat_file "$upstream:debian")[0] ne 'missing') {
1622         snag 'upstream-has-debian',
1623             "upstream ($upstream) contains debian/ directory";
1624     }
1625
1626     my $previous_dgit_view = eval {
1627         my @clogcmd = qw(dpkg-parsechangelog --format rfc822 -n2);
1628         my ($lvsn, $suite);
1629         parsechangelog_loop \@clogcmd, 'debian/changelog', sub {
1630             my ($stz, $desc) = @_;
1631             no warnings qw(exiting);
1632             printdebug 'CHANGELOG ', Dumper($desc, $stz);
1633             next unless $stz->{Date};
1634             next unless $stz->{Distribution} ne 'UNRELEASED';
1635             $lvsn = $stz->{Version};
1636             $suite = $stz->{Distribution};
1637             last;
1638         };
1639         die "neither of the first two changelog entries are released\n"
1640             unless defined $lvsn;
1641         print "last finished-looking changelog entry: ($lvsn) $suite\n";
1642         my $mtag_pat = debiantag_maintview $lvsn, '*';
1643         my $mtag = cmdoutput @git, qw(describe --always --abbrev=0 --match),
1644             $mtag_pat;
1645         die "could not find suitable maintainer view tag $mtag_pat\n"
1646             unless $mtag_pat =~ m{/};
1647         is_fast_fwd $mtag, 'HEAD' or
1648             die "HEAD is not FF from maintainer tag $mtag!";
1649         my $dtag = "archive/$mtag";
1650         is_fast_fwd $mtag, $dtag or
1651             die "dgit view tag $dtag is not FF from maintainer tag $mtag";
1652         print "will stitch in dgit view, $dtag\n";
1653         git_rev_parse $dtag;
1654     };
1655     if (!$previous_dgit_view) {
1656         $@ =~ s/^\n+//;
1657         chomp $@;
1658         print STDERR "cannot stitch in dgit view: $@\n";
1659     }
1660
1661     snags_maybe_bail_early();
1662
1663     my $work;
1664
1665     fresh_workarea();
1666     in_workarea sub {
1667         runcmd @git, qw(checkout -q -b gdr-internal), $old_head;
1668         # make a branch out of the patch queue - we'll want this in a mo
1669         runcmd qw(gbp pq import);
1670         # strip the patches out
1671         runcmd @git, qw(checkout -q gdr-internal~0);
1672         rm_subdir_cached 'debian/patches';
1673         $work = make_commit ['HEAD'], [
1674  'git-debrebase convert-from-gbp: drop patches from tree',
1675  'Delete debian/patches, as part of converting to git-debrebase format.',
1676  '[git-debrebase convert-from-gbp: drop patches from tree]'
1677                               ];
1678         # make the anchor merge
1679         # the tree is already exactly right
1680         $work = make_commit [$work, $upstream], [
1681  'git-debrebase import: declare upstream',
1682  'First breakwater merge.',
1683  '[git-debrebase anchor: declare upstream]'
1684                               ];
1685
1686         # rebase the patch queue onto the new breakwater
1687         runcmd @git, qw(reset --quiet --hard patch-queue/gdr-internal);
1688         runcmd @git, qw(rebase --quiet --onto), $work, qw(gdr-internal);
1689         $work = git_rev_parse 'HEAD';
1690
1691         if ($previous_dgit_view) {
1692             $work = make_commit [$work, $previous_dgit_view], [
1693  'git-debrebase import: declare ff from dgit archive view',
1694  '[git-debrebase pseudomerge: import-from-gbp]',
1695             ];
1696         }
1697     };
1698
1699     ffq_check $work;
1700     snags_maybe_bail();
1701     update_head_checkout $old_head, $work, 'convert-from-gbp';
1702 }
1703
1704 sub cmd_convert_to_gbp () {
1705     badusage "no arguments allowed" if @ARGV;
1706     my $head = get_head();
1707     my (undef, undef, undef, $ffq, $gdrlast) = ffq_prev_branchinfo();
1708     keycommits $head, 0;
1709     my $out;
1710     make_patches_staged $head;
1711     in_workarea sub {
1712         $out = make_commit ['HEAD'], [
1713             'Commit patch queue (converted from git-debrebase format)',
1714             '[git-debrebase convert-to-gbp: commit patches]',
1715         ];
1716     };
1717     if (defined $ffq) {
1718         push @deferred_updates, "delete $ffq";
1719         push @deferred_updates, "delete $gdrlast";
1720     }
1721     snags_maybe_bail();
1722     update_head_checkout $head, $out, "convert to gbp (v0)";
1723     print <<END or die $!;
1724 git-debrebase: converted to git-buildpackage branch format
1725 git-debrebase: WARNING: do not now run "git-debrebase" any more
1726 git-debrebase: WARNING: doing so would drop all upstream patches!
1727 END
1728 }
1729
1730 sub cmd_downstream_rebase_launder_v0 () {
1731     badusage "needs 1 argument, the baseline" unless @ARGV==1;
1732     my ($base) = @ARGV;
1733     $base = git_rev_parse $base;
1734     my $old_head = get_head();
1735     my $current = $old_head;
1736     my $topmost_keep;
1737     for (;;) {
1738         if ($current eq $base) {
1739             $topmost_keep //= $current;
1740             print " $current BASE stop\n";
1741             last;
1742         }
1743         my $cl = classify $current;
1744         print " $current $cl->{Type}";
1745         my $keep = 0;
1746         my $p0 = $cl->{Parents}[0]{CommitId};
1747         my $next;
1748         if ($cl->{Type} eq 'Pseudomerge') {
1749             print " ^".($cl->{Contributor}{Ix}+1);
1750             $next = $cl->{Contributor}{CommitId};
1751         } elsif ($cl->{Type} eq 'AddPatches' or
1752                  $cl->{Type} eq 'Changelog') {
1753             print " strip";
1754             $next = $p0;
1755         } else {
1756             print " keep";
1757             $next = $p0;
1758             $keep = 1;
1759         }
1760         print "\n";
1761         if ($keep) {
1762             $topmost_keep //= $current;
1763         } else {
1764             die "to-be stripped changes not on top of the branch\n"
1765                 if $topmost_keep;
1766         }
1767         $current = $next;
1768     }
1769     if ($topmost_keep eq $old_head) {
1770         print "unchanged\n";
1771     } else {
1772         print "updating to $topmost_keep\n";
1773         update_head_checkout
1774             $old_head, $topmost_keep,
1775             'downstream-rebase-launder-v0';
1776     }
1777 }
1778
1779 GetOptions("D+" => \$debuglevel,
1780            'noop-ok', => \$opt_noop_ok,
1781            'f=s' => \@snag_force_opts,
1782            'anchor=s' => \@opt_anchors,
1783            'force!',
1784            '-i:s' => sub {
1785                my ($opt,$val) = @_;
1786                badusage "git-debrebase: no cuddling to -i for git-rebase"
1787                    if length $val;
1788                die if $opt_defaultcmd_interactive; # should not happen
1789                $opt_defaultcmd_interactive = [ qw(-i) ];
1790                # This access to @ARGV is excessive familiarity with
1791                # Getopt::Long, but there isn't another sensible
1792                # approach.  '-i=s{0,}' does not work with bundling.
1793                push @$opt_defaultcmd_interactive, @ARGV;
1794                @ARGV=();
1795            }) or badusage "bad options\n";
1796 initdebug('git-debrebase ');
1797 enabledebug if $debuglevel;
1798
1799 my $toplevel = cmdoutput @git, qw(rev-parse --show-toplevel);
1800 chdir $toplevel or die "chdir $toplevel: $!";
1801
1802 $rd = fresh_playground "$playprefix/misc";
1803
1804 @opt_anchors = map { git_rev_parse $_ } @opt_anchors;
1805
1806 if (!@ARGV || $opt_defaultcmd_interactive || $ARGV[0] =~ m{^-}) {
1807     defaultcmd_rebase();
1808 } else {
1809     my $cmd = shift @ARGV;
1810     my $cmdfn = $cmd;
1811     $cmdfn =~ y/-/_/;
1812     $cmdfn = ${*::}{"cmd_$cmdfn"};
1813
1814     $cmdfn or badusage "unknown git-debrebase sub-operation $cmd";
1815     $cmdfn->();
1816 }
1817
1818 finish 0;