X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=git-debrebase;h=b015e885a2bb195cec1418c0123ae366cd5e41b4;hp=c0600126ba5df7701c6823330bd6d030c2ddec4f;hb=9d98fd69e8abee17a59d27023e87215d55eb9385;hpb=bfbcc503e9a18643f664f74940ab9d8ed65ddb30 diff --git a/git-debrebase b/git-debrebase index c0600126..b015e885 100755 --- a/git-debrebase +++ b/git-debrebase @@ -19,6 +19,7 @@ # along with this program. If not, see . END { $? = $Debian::Dgit::ExitStatus::desired // -1; }; +use Debian::Dgit::GDR; use Debian::Dgit::ExitStatus; use strict; @@ -33,18 +34,43 @@ use Data::Dumper; use Getopt::Long qw(:config posix_default gnu_compat bundling); use Dpkg::Version; use File::FnMatch qw(:fnmatch); +use File::Copy; + +our ($usage_message) = <<'END'; +usages: + git-debrebase [] [--|-i ] + git-debrebase [] status + git-debrebase [] prepush [--prose=...] + git-debrebase [] quick|conclude + git-debrebase [] new-upstream [
] + git-debrebase [] convert-from-gbp [] + ... +See git-debrebase(1), git-debrebase(5), dgit-maint-debrebase(7) (in dgit). +END our ($opt_force, $opt_noop_ok, @opt_anchors); our ($opt_defaultcmd_interactive); our $us = qw(git-debrebase); +$|=1; + sub badusage ($) { my ($m) = @_; - print STDERR "bad usage: $m\n"; + print STDERR "$us: bad usage: $m\n"; finish 8; } +sub getoptions_main { + my $m = shift; + local $SIG{__WARN__}; # GetOptions calls `warn' to print messages + GetOptions @_ or badusage $m; +} +sub getoptions { + my $sc = shift; + getoptions_main "bad options follow \`git-debrebase $sc'", @_; +} + sub cfg ($;$) { my ($k, $optional) = @_; local $/ = "\0"; @@ -88,6 +114,7 @@ our $rd; our $workarea; our @git = qw(git); +our @dgit = qw(dgit); sub in_workarea ($) { my ($sub) = @_; @@ -116,7 +143,7 @@ sub run_deferred_updates ($) { confess 'dangerous internal error' unless all_snags_summarised(); - my @upd_cmd = (@git, qw(update-ref --stdin -m), "debrebase: $mrest"); + my @upd_cmd = (git_update_ref_cmd "debrebase: $mrest", qw(--stdin)); debugcmd '>|', @upd_cmd; open U, "|-", @upd_cmd or die $!; foreach (@deferred_updates) { @@ -228,6 +255,20 @@ sub read_tree_subdir ($$) { runcmd @git, qw(read-tree), "--prefix=$subdir/", $new_tree_object; } +sub read_tree_debian ($) { + my ($treeish) = @_; + read_tree_subdir 'debian', "$treeish:debian"; + rm_subdir_cached 'debian/patches'; +} + +sub read_tree_upstream ($;$) { + my ($treeish, $keep_patches) = @_; + my $save = cmdoutput @git, qw(write-tree --prefix=debian/); + runcmd @git, qw(read-tree), $treeish; + read_tree_subdir 'debian', $save; + rm_subdir_cached 'debian/patches' unless $keep_patches; +}; + sub make_commit ($$) { my ($parents, $message_paras) = @_; my $tree = cmdoutput @git, qw(write-tree); @@ -268,16 +309,212 @@ sub snags_maybe_bail () { $us, $snags_tripped; } else { fail sprintf - "%s: snags: %d blockers (you could -f, or --force)", + "%s: snags: %d blocker(s) (you could -f, or --force)", $us, $snags_tripped; } } $snags_summarised = $snags_forced + $snags_tripped; } +sub snags_maybe_bail_early () { + # useful to bail out early without doing a lot of work; + # not a substitute for snags_maybe_bail. + snags_maybe_bail() if $snags_tripped && !$opt_force; +} sub any_snags () { return $snags_forced || $snags_tripped; } +sub gbp_pq_export ($$$) { + my ($bname, $base, $tip) = @_; + # must be run in a workarea. $bname and patch-queue/$bname + # ought not to exist. Leaves you on patch-queue/$bname with + # the patches staged but not committed. + runcmd @git, qw(checkout -q -b), $bname, $base; + runcmd @git, qw(checkout -q -b), "patch-queue/$bname", $tip; + my @gbp_cmd = (qw(gbp pq export)); + my $r = system shell_cmd 'exec >../gbp-pq-err 2>&1', @gbp_cmd; + if ($r) { + { local ($!,$?); copy('../gbp-pq-err', \*STDERR); } + failedcmd @gbp_cmd; + } + runcmd @git, qw(add -f debian/patches); +} + + +# xxx allow merge separately from laundering +# +# xxx docs highlight forbidden things +# xxx docs list allowable things ? +# xxx docs explicitly forbid some rebase +# +# xxx provide a way for the user to help +# xxx (eg, provide wreckage provide way to continue) + +# later/rework? +# use git-format-patch? +# our own patch identification algorithm? +# this is an alternative strategy + +sub merge_series ($$;@) { + my ($newbase, $base_q, @input_qs) = @_; + # $base_q{SeriesBase} $input_qs[]{SeriesBase} + # $base_q{SeriesTip} $input_qs[]{SeriesTip} + # ^ specifies several patch series (currently we only support exactly 2) + # return value is a commit which is the result of + # merging the two versions of the same topic branch + # $input_q[0] and $input_q[1] + # with respect to the old version + # $base_q + # all onto $newbase. + + # Creates, in *_q, a key MR for its private use + + $input_qs[$_]{MR}{S} = $_ foreach (0..$#input_qs); + $base_q->{MR}{S} = 'base'; + + my %prereq; + # $prereq{}{} = 1 or absent + # $prereq{}{} exists or not (even later) + + my $result; + + local $workarea = fresh_playground "$playprefix/merge"; + my $seriesfile = "debian/patches/series"; + in_workarea sub { + playtree_setup(); + foreach my $q ($base_q, reverse @input_qs) { + my $s = $q->{MR}{S}; + gbp_pq_export "p-$s", $q->{SeriesBase}, $q->{SeriesTip}; + if (open S, $seriesfile) { + my @earlier; + while (my $patch = ) { + chomp $patch or die $!; + foreach my $earlier (@earlier) { + $prereq{$patch}{$earlier}{$s}++ and die; + } + push @earlier, $patch; + stat "debian/patches/$patch" or die "$patch ?"; + } + S->error and die "$seriesfile $!"; + close S; + } else { + die "$seriesfile $!" unless $!==ENOENT; + } + read_tree_upstream $newbase, 1; + my $pec = make_commit [ grep { defined } $base_q->{MR}{PEC} ], [ + "Convert $s to patch queue for merging", + "[git-debrebase merge-innards patch-queue import:". + " $q->{SeriesTip}]" + ]; + runcmd @git, qw(rm -q --cached), $seriesfile; + $pec = make_commit [ $pec ], [ + "Drop series file from $s to avoid merge trouble", + "[git-debrebase merge-innards patch-queue prep:". + " $q->{SeriesTip}]" + ]; + runcmd @git, qw(reset -q --hard), $pec; + $q->{MR}{PEC} = $pec; + } + # now, because of reverse, we are on $input_q->{MR}{OQC} + runcmd @git, qw(checkout -q -b merge); + my @mergecmd = (@git, qw(merge --quiet --no-edit), "p-1"); + debugcmd '+', @mergecmd; + $!=0; $?=-1; + if (system @mergecmd) { + failedcmd @mergecmd; + } + + # We need to construct a new series file + # Firstly, resolve prereq + foreach my $f (keys %prereq) { + if (!stat_exists "debian/patches/$f") { + # git merge deleted it; that's how we tell it's not wanted + delete $prereq{$f}; + next; + } + foreach my $g (keys %{ $prereq{$f} }) { + my $gfp = $prereq{$f}{$g}; + next unless + # want to keep it + !!$gfp->{0} == !!$gfp->{1} + ? $gfp->{0} + : !$gfp->{base} + ; + delete $prereq{$f}{$g}; + } + } + + my $unsat = sub { + my ($f) = @_; + return scalar keys %{ $prereq{$f} }; + }; + + my $nodate = time + 1; + my %authordate; + # $authordate{}; + my $authordate = sub { + my ($f) = @_; + $authordate{$f} //= do { + open PF, "<", "debian/patches/$f" or die "$f $!"; + while () { + return $nodate if m/^$/; + last if s{^Date: }{}; + } + chomp; + return cmdoutput qw(date +%s -d), $_; + }; + }; + + open NS, '>', $seriesfile or die $!; + + while (keys %prereq) { + my $best; + foreach my $try (sort keys %prereq) { + if ($best) { + next if ( + $unsat->($try) <=> $unsat->($best) or + $authordate->($try) <=> $authordate->($best) or + $try cmp $best + ) >= 0; + } + $best = $try; + } + print NS "$best\n" or die $!; + delete $prereq{$best}; + foreach my $gp (values %prereq) { + delete $gp->{$best}; + } + } + + runcmd @git, qw(add), $seriesfile; + runcmd @git, qw(commit --quiet -m), 'Merged series'; + + runcmd qw(gbp pq import); + + # OK now we are on patch-queue/merge, and we need to rebase + # onto the intended parent and drop the patches from each one + + my $build = $newbase; + my @lcmd = (@git, qw(rev-list --reverse merge..patch-queue/merge)); + foreach my $c (grep /./, split /\n/, cmdoutput @lcmd) { + my $commit = git_cat_file $c, 'commit'; + read_tree_upstream $c; + my $tree = cmdoutput @git, qw(write-tree); + $commit =~ s{^parent (\S+)$}{parent $build}m or confess; + $commit =~ s{^tree (\S+)$}{tree $tree}m or confess; + open C, ">", "../mcommit" or die $!; + print C $commit or die $!; + close C or die $!; + $build = cmdoutput @git, qw(hash-object -w -t commit ../mcommit); + } + $result = $build; + runcmd @git, qw(update-ref refs/heads/result), $result; + }; + printdebug "merge_series returns $result\n"; + return $result; +} + # classify returns an info hash like this # CommitId => $objid # Hdr => # commit headers, including 1 final newline @@ -535,11 +772,27 @@ sub classify ($) { OrigParents => \@orig_ps); } - return $unknown->("complex merge"); + if (@p == 2 and + $r->{Msg} =~ m{^\[git-debrebase merged-breakwater.*\]$}m) { + # xxx ^ metadata tag needs adding to (5) + return $classify->("MergedBreakwaters"); + } + if ($r->{Msg} =~ m{^\[(git-debrebase|dgit)[: ].*\]$}m) { + return $unknown->("unknown kind of merge from $1"); + } + if (@p > 2) { + return $unknown->("octopus merge"); + } + + if (!$ENV{GIT_DEBREBASE_EXPERIMENTAL_MERGE}) { + return $unknown->("general two-parent merge"); + } + + return $classify->("VanillaMerge"); } -sub keycommits ($;$$$) { - my ($head, $furniture, $unclean, $trouble) = @_; +sub keycommits ($;$$$$) { + my ($head, $furniture, $unclean, $trouble, $fatal) = @_; # => ($anchor, $breakwater) # $unclean->("unclean-$tagsfx", $msg, $cl) @@ -552,6 +805,8 @@ sub keycommits ($;$$$) { # $trouble is for things whnich prevent the return of # anchor and breakwater information; if that is ignored, # then keycommits returns (undef, undef) instead. + # $fatal is for unprocessable commits, and should normally cause + # a failure. If ignored, agaion, (undef, undef) is returned. # # If a callback is undef, fail is called instead. # If a callback is defined but false, the situation is ignored. @@ -562,12 +817,15 @@ sub keycommits ($;$$$) { my ($anchor, $breakwater); my $clogonly; my $cl; + my $found_pm; + $fatal //= sub { fail $_[1]; }; my $x = sub { - my ($cb, $tagsfx, $why) = @_; + my ($cb, $tagsfx, $mainwhy, $xwhy) = @_; + my $why = $mainwhy.$xwhy; my $m = "branch needs laundering (run git-debrebase): $why"; fail $m unless defined $cb; return unless $cb; - $cb->("unclean-$tagsfx", $why, $cl); + $cb->("unclean-$tagsfx", $why, $cl, $mainwhy); }; for (;;) { $cl = classify $head; @@ -588,42 +846,55 @@ sub keycommits ($;$$$) { last; } elsif ($ty eq 'Upstream') { $x->($unclean, 'ordering', - "packaging change ($breakwater) follows upstream change (eg $head)") + "packaging change ($breakwater) follows upstream change"," (eg $head)") if defined $breakwater; $clogonly = undef; $breakwater = undef; } elsif ($ty eq 'Mixed') { $x->($unclean, 'mixed', - "found mixed upstream/packaging commit ($head)"); + "found mixed upstream/packaging commit"," ($head)"); $clogonly = undef; $breakwater = undef; } elsif ($ty eq 'Pseudomerge' or $ty eq 'AddPatches') { + my $found_pm = 1; $x->($furniture, (lc $ty), - "found interchange bureaucracy commit ($ty, $head)"); + "found interchange bureaucracy commit ($ty)"," ($head)"); } elsif ($ty eq 'DgitImportUnpatched') { - $x->($trouble, 'dgitimport', - "found dgit dsc import ($head)"); - $breakwater = undef; - $anchor = undef; - no warnings qw(exiting); - last; + if ($found_pm) { + $x->($trouble, 'dgitimport', + "found dgit dsc import"," ($head)"); + return (undef,undef); + } else { + $x->($fatal, 'unprocessable', + "found bare dgit dsc import with no prior history", + " ($head)"); + return (undef,undef); + } + } elsif ($ty eq 'VanillaMerge') { + $x->($trouble, 'vanillamerge', + "found vanilla merge"," ($head)"); + return (undef,undef); } else { - fail "found unprocessable commit, cannot cope: $head; $cl->{Why}"; + $x->($fatal, 'unprocessable', + "found unprocessable commit, cannot cope: $cl->{Why}", + " ($head)"); + return (undef,undef); } $head = $cl->{Parents}[0]{CommitId}; } return ($anchor, $breakwater); } -sub walk ($;$$); -sub walk ($;$$) { +sub walk ($;$$$); +sub walk ($;$$$) { my ($input, - $nogenerate,$report) = @_; + $nogenerate,$report, $report_lprefix) = @_; # => ($tip, $breakwater_tip, $last_anchor) # (or nothing, if $nogenerate) printdebug "*** WALK $input ".($nogenerate//0)." ".($report//'-')."\n"; + $report_lprefix //= ''; # go through commits backwards # we generate two lists of commits to apply: @@ -655,7 +926,7 @@ sub walk ($;$$) { my $prline = sub { return unless $report; - print $report $prdelim, @_; + print $report $prdelim, $report_lprefix, @_; $prdelim = "\n"; }; @@ -666,10 +937,11 @@ sub walk ($;$$) { if ($nogenerate) { return (undef,undef); } - die "commit $cur: Cannot cope with this commit (d.". + fail "found unprocessable commit, cannot cope". + (defined $cl->{Why} ? "; $cl->{Why}:": ':'). + " (commit $cur) (d.". (join ' ', map { sprintf "%#x", $_->{Differs} } @{ $cl->{Parents} }). - (defined $cl->{Why} ? "; $cl->{Why}": ''). ")"; }; @@ -683,6 +955,10 @@ sub walk ($;$$) { no warnings qw(exiting); last; }; + my $nomerge = sub { + fail "something useful about failed merge attempt @_ xxx".Dumper($cl); + }; + my $last_anchor; for (;;) { @@ -778,15 +1054,147 @@ sub walk ($;$$) { next; } else { # Everything is from this import. This kind of import - # is already in valid breakwater format, with the - # patches as commits. - printf $report " NoPM" if $report; - # last thing we processed will have been the first patch, - # if there is one; which is fine, so no need to rewrite - # on account of this import - $build_start->("ImportOrigin", $cur); + # is already nearly in valid breakwater format, with the + # patches as commits. Unfortunately it contains + # debian/patches/. + printdebug "*** WALK BOMB bare dgit import\n"; + $cl->{Why} = "bare dgit dsc import"; + return $bomb->(); } die "$ty ?"; + } elsif ($ty eq 'VanillaMerge' or $ty eq 'MergedBreakwaters') { + # xxx need to handle ffq if one side was unstitched + # wait both of them may be! + my $ok=1; + my $best_anchor; + # We expect to find a dominating anchor amongst the + # inputs' anchors. That will be the new anchor. + # + # More complicated is finding a merge base for the + # breakwaters. We need a merge base that is a breakwater + # commit. The ancestors of breakwater commits are more + # breakwater commits and possibly upstream commits and the + # ancestors of those upstream. Upstreams might have + # arbitrary ancestors. But any upstream commit U is + # either included in both anchors, in which case the + # earlier anchor is a better merge base than any of U's + # ancestors; or U is not included in the older anchor, in + # which case U is not an ancestor of the vanilla merge at + # all. So no upstream commit, nor any ancestor thereof, + # is a best merge base. As for non-breakwater Debian + # commits: these are never ancestors of any breakwater. + # + # So any best merge base as found by git-merge-base + # is a suitable breakwater anchor. Usually there will + # be only one. + + printdebug "*** MERGE\n"; + + # xxx avoid calling walk without nogenerate when + # we have a MergedBreakwater; instead call keycommits ? + + my @bwbcmd = (@git, qw(merge-base)); + my @ibcmd = (@git, qw(merge-base --all)); + my $might_be_in_bw = 1; + + my $ps = $cl->{Parents}; + + foreach my $p (@$ps) { + $prline->(" VanillaMerge ".$p->{Ix}); + $prprdelim->(); + my ($ptip, $pbw, $panchor) = + walk $p->{CommitId}, 0, $report, + $report_lprefix.' '; + $p->{Laundered} = $p->{SeriesTip} = $ptip; + $p->{Breakwater} = $p->{SeriesBase} = $pbw; + $p->{Anchor} = $panchor; + + $best_anchor = $panchor if + !defined $best_anchor or + is_fast_fwd $best_anchor, $panchor; + + printdebug " MERGE BA best=".($best_anchor//'-'). + " p=$panchor\n"; + } + + foreach my $p (@$ps) { + $prline->(" VanillaMerge ".$p->{Ix}); + if (!is_fast_fwd $p->{Anchor}, $best_anchor) { + $nomerge->('DivergentAnchor'); + } elsif ($p->{Anchor} eq $best_anchor) { + print $report " SameAnchor" if $report; + } else { + print $report " SupersededAnchor" if $report; + } + if ($p->{Breakwater} eq $p->{CommitId}) { + # this parent commit was its own breakwater, + # ie it is part of the breakwater + print $report " Breakwater" if $report; + } else { + $might_be_in_bw = 0; + } + push @bwbcmd, $p->{Breakwater}; + push @ibcmd, $p->{CommitId}; + } + + if ($ok && $might_be_in_bw) { + $prline->(" VanillaMerge MergedBreakwaters"); + $last_anchor = $best_anchor; + $build_start->('MergedBreakwaters', $cur); + } + + $nomerge->("alleged merged-breakwater is not a breakwater") + unless $ty eq 'VanillaMerge'; + + my $bwb = cmdoutput @bwbcmd; + + # OK, now we have a breakwater base, but we need the merge + # base for the interchange branch because we need the delta + # queue. + # + # This a the best merge base of our inputs which has the + # breakwater merge base as an ancestor. + + my @ibs = + grep { is_fast_fwd $bwb, $_ } + grep /./, + split /\n/, + cmdoutput @ibcmd; + my ($ib) = @ibs + or $nomerge->("no suitable interchange merge base"); + + $prline->(" VanillaMerge Base"); + $prprdelim->(); + my ($btip, $bbw, $banchor) = + walk $ib, 0, $report, $report_lprefix.' '; + + my $ibinfo = { SeriesTip => $btip, + SeriesBase => $bbw, + Anchor => $banchor }; + $bbw eq $bwb + or $nomerge->("interchange merge-base ($ib)'s". + " breakwater ($bbw)". + " != breakwaters' merge-base ($bwb)"); + grep { $_->{Anchor} eq $ibinfo->{Anchor} } @$ps + or $nomerge->("interchange merge-base ($ib)'s". + " anchor ($ibinfo->{SeriesBase})". + " != any merge input's anchor (". + (join ' ', map { $_->{Anchor} } @$ps). + ")"); + + + $cl->{MergeInterchangeBaseInfo} = $ibinfo; + $cl->{MergeBestAnchor} = $best_anchor; + push @brw_cl, { + %$cl, + SpecialMethod => 'MergeCreateMergedBreakwaters', + $xmsg->('construct merged breakwater from vanilla merge'), + }; + push @upp_cl, { + %$cl, + SpecialMethod => 'MergeMergeSeries', + }; + $build_start->('MergeBreakwaters', $cur); } else { printdebug "*** WALK BOMB unrecognised\n"; return $bomb->(); @@ -805,17 +1213,6 @@ sub walk ($;$$) { my $rewriting = 0; - my $read_tree_debian = sub { - my ($treeish) = @_; - read_tree_subdir 'debian', "$treeish:debian"; - rm_subdir_cached 'debian/patches'; - }; - my $read_tree_upstream = sub { - my ($treeish) = @_; - runcmd @git, qw(read-tree), $treeish; - $read_tree_debian->($build); - }; - $#upp_cl = $upp_limit if defined $upp_limit; my $committer_authline = calculate_committer_authline(); @@ -841,9 +1238,9 @@ sub walk ($;$$) { printdebug "WALK BUILD ".($cltree//'undef'). " $method (rewriting=$rewriting)\n"; if ($method eq 'Debian') { - $read_tree_debian->($cltree); + read_tree_debian($cltree); } elsif ($method eq 'Upstream') { - $read_tree_upstream->($cltree); + read_tree_upstream($cltree); } elsif ($method eq 'StartRewrite') { $rewriting = 1; next; @@ -851,13 +1248,30 @@ sub walk ($;$$) { $breakwater = $build; next; } elsif ($method eq 'DgitImportDebianUpdate') { - $read_tree_debian->($cltree); + read_tree_debian($cltree); } elsif ($method eq 'DgitImportUpstreamUpdate') { confess unless $rewriting; my $differs = (get_differs $build, $cltree); next unless $differs & D_UPS; - $read_tree_upstream->($cltree); + read_tree_upstream($cltree); push @parents, map { $_->{CommitId} } @{ $cl->{OrigParents} }; + } elsif ($method eq 'MergeCreateMergedBreakwaters') { + print "Found a general merge, will try to tidy it up.\n"; + $rewriting = 1; + read_tree_upstream($cl->{MergeBestAnchor}); + read_tree_upstream($cl->{MergeBestAnchor}); + read_tree_debian($cltree); + @parents = map { $_->{Breakwater} } @{ $cl->{Parents} }; + } elsif ($method eq 'MergeMergeSeries') { + print "Running merge resolution for $cl->{CommitId}...\n"; + $build = merge_series + $build, + $cl->{MergeInterchangeBaseInfo}, + @{ $cl->{Parents} }; + $last_anchor = $cl->{MergeBestAnchor}; + # xxx need to check the tree somehow + print "Merge resolution successful.\n"; + next; } else { confess "$method ?"; } @@ -930,6 +1344,18 @@ sub update_head_postlaunder ($$$) { runcmd @git, qw(rm --quiet --ignore-unmatch -rf debian/patches); } +sub currently_rebasing() { + foreach (qw(rebase-merge rebase-apply)) { + return 1 if stat_exists "$maindir_gitdir/$_"; + } + return 0; +} + +sub bail_if_rebasing() { + fail "you are in the middle of a git-rebase already" + if currently_rebasing(); +} + sub do_launder_head ($) { my ($reflogmsg) = @_; my $old = get_head(); @@ -957,7 +1383,8 @@ sub defaultcmd_rebase () { } sub cmd_analyse () { - die if ($ARGV[0]//'') =~ m/^-/; + badusage "analyse does not support any options" + if @ARGV and $ARGV[0] =~ m/^-/; badusage "too many arguments to analyse" if @ARGV>1; my ($old) = @ARGV; if (defined $old) { @@ -970,39 +1397,31 @@ sub cmd_analyse () { } sub ffq_prev_branchinfo () { - # => ('status', "message", [$current, $ffq_prev, $gdrlast]) - # 'status' may be - # branch message is undef - # weird-symref } no $current, - # notbranch } no $ffq_prev my $current = git_get_symref(); - return ('detached', 'detached HEAD') unless defined $current; - return ('weird-symref', 'HEAD symref is not to refs/') - unless $current =~ m{^refs/}; - my $ffq_prev = "refs/$ffq_refprefix/$'"; - my $gdrlast = "refs/$gdrlast_refprefix/$'"; - printdebug "ffq_prev_branchinfo branch current $current\n"; - return ('branch', undef, $current, $ffq_prev, $gdrlast); + return gdr_ffq_prev_branchinfo($current); } -sub record_ffq_prev_deferred () { - # => ('status', "message") - # 'status' may be - # deferred message is undef +sub ffq_check ($;$$) { + # calls $ff and/or $notff zero or more times + # then returns either (status,message) where status is # exists # detached # weird-symref # notbranch - # if not ff from some branch we should be ff from, is an snag - # if "deferred", will have added something about that to - # @deferred_update_messages, and also maybe printed (already) - # some messages about ff checks + # or (undef,undef, $ffq_prev,$gdrlast) + # $ff and $notff are called like this: + # $ff->("message for stdout\n"); + # $notff->('snag-name', $message); + # normally $currentval should be HEAD + my ($currentval, $ff, $notff) =@_; + + $ff //= sub { print $_[0] or die $!; }; + $notff //= \&snag; + my ($status, $message, $current, $ffq_prev, $gdrlast) = ffq_prev_branchinfo(); return ($status, $message) unless $status eq 'branch'; - my $currentval = get_head(); - my $exists = git_get_ref $ffq_prev; return ('exists',"$ffq_prev already exists") if $exists; @@ -1026,17 +1445,17 @@ sub record_ffq_prev_deferred () { } return if $invert; my $lrval = git_get_ref $lrref; - return unless defined $lrval; + return unless length $lrval; if (is_fast_fwd $lrval, $currentval) { - print "OK, you are ahead of $lrref\n" or die $!; + $ff->("OK, you are ahead of $lrref\n"); $checked{$lrref} = 1; } elsif (is_fast_fwd $currentval, $lrval) { $checked{$lrref} = -1; - snag 'behind', "you are behind $lrref, divergence risk"; + $notff->('behind', "you are behind $lrref, divergence risk"); } else { $checked{$lrref} = -1; - snag 'diverged', "you have diverged from $lrref"; + $notff->('diverged', "you have diverged from $lrref"); } }; @@ -1061,12 +1480,32 @@ sub record_ffq_prev_deferred () { } elsif ($branch =~ m{^master$}) { $check->("refs/remotes/dgit/dgit/sid", 'remote dgit branch for sid'); } + return (undef, undef, $ffq_prev, $gdrlast); +} + +sub record_ffq_prev_deferred () { + # => ('status', "message") + # 'status' may be + # deferred message is undef + # exists + # detached + # weird-symref + # notbranch + # if not ff from some branch we should be ff from, is an snag + # if "deferred", will have added something about that to + # @deferred_update_messages, and also maybe printed (already) + # some messages about ff checks + bail_if_rebasing(); + my $currentval = get_head(); + + my ($status,$message, $ffq_prev,$gdrlast) = ffq_check $currentval; + return ($status,$message) if defined $status; snags_maybe_bail(); push @deferred_updates, "update $ffq_prev $currentval $git_null_obj"; push @deferred_updates, "delete $gdrlast"; - push @deferred_update_messages, "Recorded current head for preservation"; + push @deferred_update_messages, "Recorded previous head for preservation"; return ('deferred', undef); } @@ -1080,6 +1519,7 @@ sub record_ffq_auto () { } sub ffq_prev_info () { + bail_if_rebasing(); # => ($ffq_prev, $gdrlast, $ffq_prev_commitish) my ($status, $message, $current, $ffq_prev, $gdrlast) = ffq_prev_branchinfo(); @@ -1136,7 +1576,35 @@ sub do_stitch ($;$) { stitch($dangling_head, $ffq_prev, $gdrlast, $ffq_prev_commitish, $prose); } -sub cmd_new_upstream_v0 () { +sub upstream_commitish_search ($$) { + my ($upstream_version, $tried) = @_; + # todo: at some point maybe use git-deborig to do this + foreach my $tagpfx ('', 'v', 'upstream/') { + my $tag = $tagpfx.(dep14_version_mangle $upstream_version); + my $new_upstream = git_get_ref "refs/tags/$tag"; + push @$tried, $tag; + return $new_upstream if length $new_upstream; + } +} + +sub resolve_upstream_version ($$) { + my ($new_upstream, $upstream_version) = @_; + + if (!defined $new_upstream) { + my @tried; + $new_upstream = upstream_commitish_search $upstream_version, \@tried; + if (!length $new_upstream) { + fail "Could not determine appropriate upstream commitish.\n". + " (Tried these tags: @tried)\n". + " Check version, and specify upstream commitish explicitly."; + } + } + $new_upstream = git_rev_parse $new_upstream; + + return $new_upstream; +} + +sub cmd_new_upstream () { # automatically and unconditionally launders before rebasing # if rebase --abort is used, laundering has still been done @@ -1145,10 +1613,17 @@ sub cmd_new_upstream_v0 () { badusage "need NEW-VERSION [UPS-COMMITTISH]" unless @ARGV >= 1; # parse args - low commitment - my $new_version = (new Dpkg::Version scalar(shift @ARGV), check => 1); - my $new_upstream_version = $new_version->version(); + my $spec_version = shift @ARGV; + my $new_version = (new Dpkg::Version $spec_version, check => 1); + fail "bad version number \`$spec_version'" unless defined $new_version; + if ($new_version->is_native()) { + $new_version = (new Dpkg::Version "$spec_version-1", check => 1); + } - my $new_upstream = git_rev_parse (shift @ARGV // 'upstream'); + my $new_upstream = shift @ARGV; + my $new_upstream_version = upstreamversion $new_version; + $new_upstream = + resolve_upstream_version $new_upstream, $new_upstream_version; record_ffq_auto(); @@ -1207,11 +1682,13 @@ sub cmd_new_upstream_v0 () { ) { my @oldpieces = (split / /, $1); my $old_n_parents = scalar @{ $old_upstream->{Parents} }; - if (@oldpieces != $old_n_parents) { + if ($old_n_parents != @oldpieces && + $old_n_parents != @oldpieces + 1) { snag 'upstream-confusing', sprintf "previous upstream combine %s". - " mentions %d pieces (each implying one orig commit)". - " but has %d parents", + " mentions %d pieces (each implying one parent)". + " but has %d parents". + " (one per piece plus maybe a previous combine)", $old_upstream->{CommitId}, (scalar @oldpieces), $old_n_parents; @@ -1224,7 +1701,8 @@ sub cmd_new_upstream_v0 () { $oldpieces[0] = ''; foreach my $i (0..$#oldpieces) { my $n = $oldpieces[$i]; - $piece->($n, Old => $old_upstream->{CommitId}.'^'.($i+1)); + my $hat = 1 + $i + ($old_n_parents - @oldpieces); + $piece->($n, Old => $old_upstream->{CommitId}.'^'.$hat); } } } else { @@ -1338,6 +1816,8 @@ END 'launder for new upstream'; my @cmd = (@git, qw(rebase --onto), $new_bw, $old_bw, @ARGV); + local $ENV{GIT_REFLOG_ACTION} = git_reflog_action_msg + "debrebase new-upstream $new_version: rebase"; runcmd @cmd; # now it's for the user to sort out } @@ -1366,9 +1846,97 @@ sub cmd_breakwater () { print "$bw\n" or die $!; } +sub cmd_status () { + badusage "no arguments allowed" if @ARGV; + + # todo: gdr status should print divergence info + # todo: gdr status should print upstream component(s) info + # todo: gdr should leave/maintain some refs with this kind of info ? + + my $oldest = { Badness => 0 }; + my $newest; + my $note = sub { + my ($badness, $ourmsg, $snagname, $dummy, $cl, $kcmsg) = @_; + if ($oldest->{Badness} < $badness) { + $oldest = $newest = undef; + } + $oldest = { + Badness => $badness, + CommitId => $cl->{CommitId}, + OurMsg => $ourmsg, + KcMsg => $kcmsg, + }; + $newest //= $oldest; + }; + my ($anchor, $bw) = keycommits +(git_rev_parse 'HEAD'), + sub { $note->(1, 'branch contains furniture (not laundered)', @_); }, + sub { $note->(2, 'branch is unlaundered', @_); }, + sub { $note->(3, 'branch needs laundering', @_); }, + sub { $note->(4, 'branch not in git-debrebase form', @_); }; + + my $prcommitinfo = sub { + my ($cid) = @_; + flush STDOUT or die $!; + runcmd @git, qw(--no-pager log -n1), + '--pretty=format: %h %s%n', + $cid; + }; + + print "current branch contents, in git-debrebase terms:\n"; + if (!$oldest->{Badness}) { + print " branch is laundered\n"; + } else { + print " $oldest->{OurMsg}\n"; + my $printed = ''; + foreach my $info ($oldest, $newest) { + my $cid = $info->{CommitId}; + next if $cid eq $printed; + $printed = $cid; + print " $info->{KcMsg}\n"; + $prcommitinfo->($cid); + } + } + + my $prab = sub { + my ($cid, $what) = @_; + if (!defined $cid) { + print " $what is not well-defined\n"; + } else { + print " $what\n"; + $prcommitinfo->($cid); + } + }; + print "key git-debrebase commits:\n"; + $prab->($anchor, 'anchor'); + $prab->($bw, 'breakwater'); + + my ($ffqstatus, $ffq_msg, $current, $ffq_prev, $gdrlast) = + ffq_prev_branchinfo(); + + print "branch and ref status, in git-debrebase terms:\n"; + if ($ffq_msg) { + print " $ffq_msg\n"; + } else { + $ffq_prev = git_get_ref $ffq_prev; + $gdrlast = git_get_ref $gdrlast; + if ($ffq_prev) { + print " unstitched; previous tip was:\n"; + $prcommitinfo->($ffq_prev); + } elsif (!$gdrlast) { + print " stitched? (no record of git-debrebase work)\n"; + } elsif (is_fast_fwd $gdrlast, 'HEAD') { + print " stitched\n"; + } else { + print " not git-debrebase (diverged since last stitch)\n" + } + } + print "you are currently rebasing\n" if currently_rebasing(); +} + sub cmd_stitch () { my $prose = 'stitch'; - GetOptions('prose=s', \$prose) or die badusage("bad options to stitch"); + getoptions("stitch", + 'prose=s', \$prose); badusage "no arguments allowed" if @ARGV; do_stitch $prose, 0; } @@ -1393,6 +1961,24 @@ sub cmd_conclude () { do_stitch 'quick'; } +sub cmd_scrap () { + if (currently_rebasing()) { + runcmd @git, qw(rebase --abort); + } + my ($ffq_prev, $gdrlast, $ffq_prev_commitish) = ffq_prev_info(); + if (!$ffq_prev_commitish) { + fail "No ongoing git-debrebase session." unless $opt_noop_ok; + finish 0; + } + my $scrapping_head = get_head(); + badusage "no arguments allowed" if @ARGV; + push @deferred_updates, + "update $gdrlast $ffq_prev_commitish $git_null_obj", + "update $ffq_prev $git_null_obj $ffq_prev_commitish"; + snags_maybe_bail(); + update_head_checkout $scrapping_head, $ffq_prev_commitish, "scrap"; +} + sub make_patches_staged ($) { my ($head) = @_; # Produces the patches that would result from $head if it were @@ -1400,10 +1986,7 @@ sub make_patches_staged ($) { my ($secret_head, $secret_bw, $last_anchor) = walk $head; fresh_workarea(); in_workarea sub { - runcmd @git, qw(checkout -q -b bw), $secret_bw; - runcmd @git, qw(checkout -q -b patch-queue/bw), $secret_head; - runcmd qw(gbp pq export); - runcmd @git, qw(add debian/patches); + gbp_pq_export 'bw', $secret_bw, $secret_head; }; } @@ -1421,44 +2004,60 @@ sub make_patches ($) { '[git-debrebase: export and commit patches]', ]; }; - my $d = get_differs $head, $out; - if ($d == 0) { - return undef; # nothing to do - } elsif ($d == D_PAT_ADD) { - return $out; # OK - } else { - fail "Patch export produced patch amendments". - " (abandoned output commit $out).". - " Try laundering first."; - } + return $out; } sub cmd_make_patches () { + my $opt_quiet_would_amend; + getoptions("make-patches", + 'quiet-would-amend!', \$opt_quiet_would_amend); badusage "no arguments allowed" if @ARGV; + bail_if_rebasing(); my $old_head = get_head(); my $new = make_patches $old_head; - snags_maybe_bail(); - if (!$new) { + my $d = get_differs $old_head, $new; + if ($d == 0) { fail "No (more) patches to export." unless $opt_noop_ok; return; + } elsif ($d == D_PAT_ADD) { + snags_maybe_bail(); + update_head_checkout $old_head, $new, 'make-patches'; + } else { + print STDERR failmsg + "Patch export produced patch amendments". + " (abandoned output commit $new).". + " Try laundering first." + unless $opt_quiet_would_amend; + finish 7; } - update_head_checkout $old_head, $new, 'make-patches'; } sub cmd_convert_from_gbp () { - badusage "needs 1 optional argument, the upstream git rev" + badusage "want only 1 optional argument, the upstream git commitish" unless @ARGV<=1; + + my $clogp = parsechangelog(); + my $version = $clogp->{'Version'} + // die "missing Version from changelog"; + my ($upstream_spec) = @ARGV; - $upstream_spec //= 'refs/heads/upstream'; - my $upstream = git_rev_parse $upstream_spec; + + my $upstream_version = upstreamversion $version; + my $upstream = + resolve_upstream_version($upstream_spec, $upstream_version); + my $old_head = get_head(); my $upsdiff = get_differs $upstream, $old_head; if ($upsdiff & D_UPS) { - runcmd @git, qw(--no-pager diff), + runcmd @git, qw(--no-pager diff --stat), $upstream, $old_head, qw( -- :!/debian :/); - fail "upstream ($upstream_spec) and HEAD are not identical in upstream files"; + fail <{Date}; + next unless $stz->{Distribution} ne 'UNRELEASED'; + $lvsn = $stz->{Version}; + $suite = $stz->{Distribution}; + last; + }; + die "neither of the first two changelog entries are released\n" + unless defined $lvsn; + print "last finished-looking changelog entry: ($lvsn) $suite\n"; + my $mtag_pat = debiantag_maintview $lvsn, '*'; + my $mtag = cmdoutput @git, qw(describe --always --abbrev=0 --match), + $mtag_pat; + die "could not find suitable maintainer view tag $mtag_pat\n" + unless $mtag_pat =~ m{/}; + is_fast_fwd $mtag, 'HEAD' or + die "HEAD is not FF from maintainer tag $mtag!"; + my $dtag = "archive/$mtag"; + is_fast_fwd $mtag, $dtag or + die "dgit view tag $dtag is not FF from maintainer tag $mtag"; + print "will stitch in dgit view, $dtag\n"; + git_rev_parse $dtag; + }; + if (!$previous_dgit_view) { + $@ =~ s/^\n+//; + chomp $@; + print STDERR "cannot stitch in dgit view: $@\n"; + } + + snags_maybe_bail_early(); my $work; @@ -1509,8 +2143,17 @@ sub cmd_convert_from_gbp () { runcmd @git, qw(reset --quiet --hard patch-queue/gdr-internal); runcmd @git, qw(rebase --quiet --onto), $work, qw(gdr-internal); $work = git_rev_parse 'HEAD'; + + if ($previous_dgit_view) { + $work = make_commit [$work, $previous_dgit_view], [ + 'git-debrebase import: declare ff from dgit archive view', + '[git-debrebase pseudomerge: import-from-gbp]', + ]; + } }; + ffq_check $work; + snags_maybe_bail(); update_head_checkout $old_head, $work, 'convert-from-gbp'; } @@ -1540,6 +2183,194 @@ git-debrebase: WARNING: doing so would drop all upstream patches! END } +sub cmd_convert_from_dgit_view () { + my $clogp = parsechangelog(); + + my $bpd = (cfg 'dgit.default.build-products-dir',1) // '..'; + my $do_origs = 1; + my $do_tags = 1; + my $always = 0; + my $diagnose = 0; + + getoptions("convert-from-dgit-view", + 'diagnose!', \$diagnose, + 'build-products-dir:s', \$bpd, + 'origs!', \$do_origs, + 'tags!', \$do_tags, + 'always-convert-anyway!', \$always); + fail "takes 1 optional argument, the upstream commitish" if @ARGV>1; + + my @upstreams; + + if (@ARGV) { + my $spec = shift @ARGV; + my $commit = git_rev_parse "$spec^{commit}"; + push @upstreams, { Commit => $commit, + Source => "$ARGV[0], from command line", + Only => 1, + }; + } + + my $head = get_head(); + + if (!$always) { + my $troubles = 0; + my $trouble = sub { $troubles++; }; + keycommits $head, sub{}, sub{}, $trouble, $trouble; + printdebug "troubles=$troubles\n"; + if (!$troubles) { + print STDERR <{Version}; + print STDERR "Considering possible commits corresponding to upstream:\n"; + + if (!@upstreams) { + if ($do_tags) { + my @tried; + my $ups_tag = upstream_commitish_search $version, \@tried; + if ($ups_tag) { + my $this = "git tag $tried[-1]"; + push @upstreams, { Commit => $ups_tag, + Source => $this, + }; + } else { + printf STDERR + " git tag: no suitable tag found (tried %s)\n", + "@tried"; + } + } + if ($do_origs) { + my $p = $clogp->{'Source'}; + # we do a quick check to see if there are plausible origs + my $something=0; + if (!opendir BPD, $bpd) { + die "$bpd: opendir: $!" unless $!==ENOENT; + } else { + while ($!=0, my $f = readdir BPD) { + next unless is_orig_file_of_p_v $f, $p, $version; + printf STDERR + " orig: found what looks like a .orig, %s\n", + "$bpd/$f"; + $something=1; + last; + } + die "read $bpd: $!" if $!; + closedir BPD; + } + if ($something) { + my $tree = cmdoutput + @dgit, qw(--build-products-dir), $bpd, + qw(print-unapplied-treeish); + fresh_workarea(); + in_workarea sub { + runcmd @git, qw(reset --quiet), $tree, qw(-- .); + rm_subdir_cached 'debian'; + $tree = cmdoutput @git, qw(write-tree); + my $ups_synth = make_commit [], [ < $ups_synth, + Source => "orig(s) imported via dgit", + }; + } + } else { + printf STDERR + " orig: no suitable origs found (looked for %s in %s)\n", + "${p}_".(stripeoch $version)."...", $bpd; + } + } + } + + my $some_patches = stat_exists 'debian/patches/series'; + + print STDERR "Evaluating possible commits corresponding to upstream:\n"; + + my $result; + foreach my $u (@upstreams) { + my $work = $head; + fresh_workarea(); + in_workarea sub { + runcmd @git, qw(reset --quiet), $u->{Commit}, qw(-- .); + runcmd @git, qw(checkout), $u->{Commit}, qw(-- .); + runcmd @git, qw(clean -xdff); + runcmd @git, qw(checkout), $head, qw(-- debian); + if ($some_patches) { + rm_subdir_cached 'debian/patches'; + $work = make_commit [ $work ], [ + 'git-debrebase convert-from-dgit-view: drop upstream changes from breakwater', + "Drop upstream changes, and delete debian/patches, as part of converting\n". + "to git-debrebase format. Upstream changes will appear as commits.", + '[git-debrebase convert-from-dgit-view: drop patches from tree]' + ]; + } + $work = make_commit [ $work, $u->{Commit} ], [ + 'git-debrebase convert-from-dgit-view: declare upstream', + '(Re)constructed breakwater merge.', + '[git-debrebase anchor: declare upstream]' + ]; + runcmd @git, qw(checkout --quiet -b mk), $work; + if ($some_patches) { + runcmd @git, qw(checkout), $head, qw(-- debian/patches); + runcmd @git, qw(reset --quiet); + my @gbp_cmd = (qw(gbp pq import)); + if (!$diagnose) { + my $gbp_err = "../gbp-pq-err"; + @gbp_cmd = shell_cmd "exec >$gbp_err 2>&1", @gbp_cmd; + } + my $r = system @gbp_cmd; + if ($r) { + printf STDERR + " %s: couldn't apply patches: gbp pq %s", + $u->{Source}, waitstatusmsg(); + return; + } + } + my $work = git_rev_parse qw(HEAD); + my $diffout = cmdoutput @git, qw(diff-tree --stat HEAD), $work; + if (length $diffout) { + print STDERR + " $u->{Source}: applying patches gives different tree\n"; + print STDERR $diffout if $diagnose; + return; + } + # OMG! + $u->{Result} = $work; + $result = $u; + }; + last if $result; + } + + if (!$result) { + fail <{Source}; + + ffq_check $result->{Result}; + snags_maybe_bail(); + update_head_checkout $head, $result->{Result}, + 'convert-from-dgit-view'; +} + sub cmd_downstream_rebase_launder_v0 () { badusage "needs 1 argument, the baseline" unless @ARGV==1; my ($base) = @ARGV; @@ -1589,10 +2420,13 @@ sub cmd_downstream_rebase_launder_v0 () { } } -GetOptions("D+" => \$debuglevel, +getoptions_main + ("bad options\n", + "D+" => \$debuglevel, 'noop-ok', => \$opt_noop_ok, 'f=s' => \@snag_force_opts, 'anchor=s' => \@opt_anchors, + '--dgit=s' => \($dgit[0]), 'force!', '-i:s' => sub { my ($opt,$val) = @_; @@ -1605,7 +2439,10 @@ GetOptions("D+" => \$debuglevel, # approach. '-i=s{0,}' does not work with bundling. push @$opt_defaultcmd_interactive, @ARGV; @ARGV=(); - }) or die badusage "bad options\n"; + }, + 'help' => sub { print $usage_message or die $!; finish 0; }, + ); + initdebug('git-debrebase '); enabledebug if $debuglevel;