chiark / gitweb /
git-debrebase: keycommits: Pass $cl to callbacks
[dgit.git] / git-debrebase
index c02fe8a27e2c25d8c573ce88b7ddda8ca3828cb4..c0600126ba5df7701c6823330bd6d030c2ddec4f 100755 (executable)
@@ -18,6 +18,9 @@
 # You should have received a copy of the GNU General Public License
 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
+END { $? = $Debian::Dgit::ExitStatus::desired // -1; };
+use Debian::Dgit::ExitStatus;
+
 use strict;
 
 use Debian::Dgit qw(:DEFAULT :playground);
@@ -39,7 +42,7 @@ our $us = qw(git-debrebase);
 sub badusage ($) {
     my ($m) = @_;
     print STDERR "bad usage: $m\n";
-    exit 12;
+    finish 8;
 }
 
 sub cfg ($;$) {
@@ -99,12 +102,20 @@ sub fresh_workarea () {
     in_workarea sub { playtree_setup };
 }
 
+our $snags_forced = 0;
+our $snags_tripped = 0;
+our $snags_summarised = 0;
 our @deferred_updates;
 our @deferred_update_messages;
 
+sub all_snags_summarised () {
+    $snags_forced + $snags_tripped == $snags_summarised;
+}
 sub run_deferred_updates ($) {
     my ($mrest) = @_;
 
+    confess 'dangerous internal error' unless all_snags_summarised();
+
     my @upd_cmd = (@git, qw(update-ref --stdin -m), "debrebase: $mrest");
     debugcmd '>|', @upd_cmd;
     open U, "|-", @upd_cmd or die $!;
@@ -227,10 +238,8 @@ sub make_commit ($$) {
 }
 
 our @snag_force_opts;
-our $snags_forced;
-our $snags_tripped;
-sub snag ($$) {
-    my ($tag,$msg) = @_;
+sub snag ($$;@) {
+    my ($tag,$msg) = @_; # ignores extra args, for benefit of keycommits
     if (grep { $_ eq $tag } @snag_force_opts) {
        $snags_forced++;
        print STDERR "git-debrebase: snag ignored (-f$tag): $msg\n";
@@ -240,7 +249,13 @@ sub snag ($$) {
     }
 }
 
+# Important: all mainline code must call snags_maybe_bail after
+# any point where snag might be called, but before making changes
+# (eg before any call to run_deferred_updates).  snags_maybe_bail
+# may be called more than once if necessary (but this is not ideal
+# because then the messages about number of snags may be confusing).
 sub snags_maybe_bail () {
+    return if all_snags_summarised();
     if ($snags_forced) {
        printf STDERR
            "%s: snags: %d overriden by individual -f options\n",
@@ -257,6 +272,7 @@ sub snags_maybe_bail () {
                $us, $snags_tripped;
        }
     }
+    $snags_summarised = $snags_forced + $snags_tripped;
 }
 sub any_snags () {
     return $snags_forced || $snags_tripped;
@@ -417,6 +433,23 @@ sub classify ($) {
        # way also there's also an easy rune to look for the upstream
        # patches (--topo-order).
 
+       # Also this makes --first-parent be slightly more likely to
+       # be useful - it makes it provide a linearised breakwater history.
+
+       # Of course one can say somthing like
+       #  gitk -- ':/' ':!/debian'
+       # to get _just_ the commits touching upstream files, and by
+       # the TREESAME logic in git-rev-list this will leave the
+       # breakwater into upstream at the first anchor.  But that
+       # doesn't report debian/ changes at all.
+
+       # Other observations about gitk: by default, gitk seems to
+       # produce output in a different order to git-rev-list.  I
+       # can't seem to find this documented anywhere.  gitk
+       # --date-order DTRT.  But, gitk always seems to put the
+       # parents from left to right, in order, so it's easy to see
+       # which way round a pseudomerge is.
+
        $p[0]{IsOrigin} and $badanchor->("is an origin commit");
        $p[1]{Differs} & ~DS_DEB and
            $badanchor->("upstream files differ from left parent");
@@ -509,9 +542,9 @@ sub keycommits ($;$$$) {
     my ($head, $furniture, $unclean, $trouble) = @_;
     # => ($anchor, $breakwater)
 
-    # $unclean->("unclean-$tagsfx", $msg)
-    # $furniture->("unclean-$tagsfx", $msg)
-    # $dgitimport->("unclean-$tagsfx", $msg)
+    # $unclean->("unclean-$tagsfx", $msg, $cl)
+    # $furniture->("unclean-$tagsfx", $msg, $cl)
+    # $dgitimport->("unclean-$tagsfx", $msg, $cl))
     #   is callled for each situation or commit that
     #   wouldn't be found in a laundered branch
     # $furniture is for furniture commits such as might be found on an
@@ -528,15 +561,16 @@ sub keycommits ($;$$$) {
 
     my ($anchor, $breakwater);
     my $clogonly;
+    my $cl;
     my $x = sub {
        my ($cb, $tagsfx, $why) = @_;
        my $m = "branch needs laundering (run git-debrebase): $why";
        fail $m unless defined $cb;
        return unless $cb;
-       $cb->("unclean-$tagsfx", $why);
+       $cb->("unclean-$tagsfx", $why, $cl);
     };
     for (;;) {
-       my $cl = classify $head;
+       $cl = classify $head;
        my $ty = $cl->{Type};
        if ($ty eq 'Packaging') {
            $breakwater //= $clogonly;
@@ -560,7 +594,7 @@ sub keycommits ($;$$$) {
            $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
@@ -901,6 +935,7 @@ sub do_launder_head ($) {
     my $old = get_head();
     record_ffq_auto();
     my ($tip,$breakwater) = walk $old;
+    snags_maybe_bail();
     update_head_postlaunder $old, $tip, $reflogmsg;
     return ($tip,$breakwater);
 }
@@ -1075,6 +1110,8 @@ sub stitch ($$$$$) {
        }
     }
     fresh_workarea();
+    # We make pseudomerges with L as the contributing parent.
+    # This makes git rev-list --first-parent work properly.
     my $new_head = make_commit [ $old_head, $ffq_prev ], [
        'Declare fast forward / record previous work',
         "[git-debrebase pseudomerge: $prose]",
@@ -1094,6 +1131,7 @@ sub do_stitch ($;$) {
     my $dangling_head = get_head();
 
     keycommits $dangling_head, $unclean,$unclean,$unclean;
+    snags_maybe_bail();
 
     stitch($dangling_head, $ffq_prev, $gdrlast, $ffq_prev_commitish, $prose);
 }
@@ -1165,13 +1203,29 @@ sub cmd_new_upstream_v0 () {
 
     if ($old_upstream && $old_upstream->{Msg} =~ m{^\[git-debrebase }m) {
        if ($old_upstream->{Msg} =~
- m{^\[git-debrebase upstream-combine \.((?: $extra_orig_namepart_re)+)\:.*\]$}m
+ m{^\[git-debrebase upstream-combine (\.(?: $extra_orig_namepart_re)+)\:.*\]$}m
           ) {
-           my @oldpieces = ('', split / /, $1);
-           my $parentix = -1 + scalar @{ $old_upstream->{Parents} };
-           foreach my $i (0..$#oldpieces) {
-               my $n = $oldpieces[$i];
-               $piece->($n, Old => $old_upstream->{CommitId}.'^'.$parentix);
+           my @oldpieces = (split / /, $1);
+           my $old_n_parents = scalar @{ $old_upstream->{Parents} };
+           if (@oldpieces != $old_n_parents) {
+               snag 'upstream-confusing', sprintf
+                   "previous upstream combine %s".
+                   " mentions %d pieces (each implying one orig commit)".
+                   " but has %d parents",
+                   $old_upstream->{CommitId},
+                   (scalar @oldpieces),
+                   $old_n_parents;
+           } elsif ($oldpieces[0] ne '.') {
+               snag 'upstream-confusing', sprintf
+                   "previous upstream combine %s".
+                   " first piece is not \`.'",
+                   $oldpieces[0];
+           } else {
+               $oldpieces[0] = '';
+               foreach my $i (0..$#oldpieces) {
+                   my $n = $oldpieces[$i];
+                   $piece->($n, Old => $old_upstream->{CommitId}.'^'.($i+1));
+               }
            }
        } else {
            snag 'upstream-confusing',
@@ -1323,7 +1377,7 @@ sub cmd_prepush () { cmd_stitch(); }
 sub cmd_quick () {
     badusage "no arguments allowed" if @ARGV;
     do_launder_head 'launder for git-debrebase quick';
-    do_stitch 'quick', \&snag;
+    do_stitch 'quick';
 }
 
 sub cmd_conclude () {
@@ -1336,7 +1390,59 @@ sub cmd_conclude () {
     
     badusage "no arguments allowed" if @ARGV;
     do_launder_head 'launder for git-debrebase quick';
-    do_stitch 'quick', \&snag;
+    do_stitch 'quick';
+}
+
+sub make_patches_staged ($) {
+    my ($head) = @_;
+    # Produces the patches that would result from $head if it were
+    # laundered.
+    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);
+    };
+}
+
+sub make_patches ($) {
+    my ($head) = @_;
+    keycommits $head, 0, \&snag;
+    make_patches_staged $head;
+    my $out;
+    in_workarea sub {
+       my $ptree = cmdoutput @git, qw(write-tree --prefix=debian/patches/);
+       runcmd @git, qw(read-tree), $head;
+       read_tree_subdir 'debian/patches', $ptree;
+       $out = make_commit [$head], [
+            'Commit patch queue (exported by git-debrebase)',
+            '[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.";
+    }
+}
+
+sub cmd_make_patches () {
+    badusage "no arguments allowed" if @ARGV;
+    my $old_head = get_head();
+    my $new = make_patches $old_head;
+    snags_maybe_bail();
+    if (!$new) {
+       fail "No (more) patches to export." unless $opt_noop_ok;
+       return;
+    }
+    update_head_checkout $old_head, $new, 'make-patches';
 }
 
 sub cmd_convert_from_gbp () {
@@ -1412,14 +1518,10 @@ sub cmd_convert_to_gbp () {
     badusage "no arguments allowed" if @ARGV;
     my $head = get_head();
     my (undef, undef, undef, $ffq, $gdrlast) = ffq_prev_branchinfo();
-    my ($anchor, $bw) = keycommits $head, 0;
-    fresh_workarea();
+    keycommits $head, 0;
     my $out;
+    make_patches_staged $head;
     in_workarea sub {
-       runcmd @git, qw(checkout -q -b bw), $bw;
-       runcmd @git, qw(checkout -q -b patch-queue/bw), $head;
-       runcmd qw(gbp pq export);
-       runcmd @git, qw(add debian/patches);
        $out = make_commit ['HEAD'], [
             'Commit patch queue (converted from git-debrebase format)',
             '[git-debrebase convert-to-gbp: commit patches]',
@@ -1429,6 +1531,7 @@ sub cmd_convert_to_gbp () {
        push @deferred_updates, "delete $ffq";
        push @deferred_updates, "delete $gdrlast";
     }
+    snags_maybe_bail();
     update_head_checkout $head, $out, "convert to gbp (v0)";
     print <<END or die $!;
 git-debrebase: converted to git-buildpackage branch format
@@ -1524,3 +1627,5 @@ if (!@ARGV || $opt_defaultcmd_interactive || $ARGV[0] =~ m{^-}) {
     $cmdfn or badusage "unknown git-debrebase sub-operation $cmd";
     $cmdfn->();
 }
+
+finish 0;