git-debrebase: Provide new get_tree and trees_diff_walk

[dgit.git] / git-debrebase

diff --git a/git-debrebase b/git-debrebase
index 1e205c609d699b6c9172df13055521cbaea70666..d04f2a3af54882d2f256ea82341349525e54c5e9 100755 (executable)
--- a/git-debrebase
+++ b/git-debrebase
@@ -50,9 +50,11 @@ usages:
 See git-debrebase(1), git-debrebase(5), dgit-maint-debrebase(7) (in dgit).
 END
 
-our ($opt_force, $opt_noop_ok, @opt_anchors);
+our ($opt_force, $opt_careful, $opt_noop_ok, @opt_anchors);
 our ($opt_defaultcmd_interactive);
 
+$opt_careful = 1;
+
 our $us = qw(git-debrebase);
 
 our $wrecknoteprefix = 'refs/debrebase/wreckage';
@@ -181,6 +183,62 @@ sub run_deferred_updates ($) {
     @deferred_update_messages = ();
 }
 
+sub get_tree ($) {
+    # tree object name => ([ $name, $info ], ...)
+    # where $name is the sort key, ie has / at end for subtrees
+    # $info is the LHS from git-ls-tree (<mode> <type> <hash>)
+    # will crash if $x does not exist, so don't do that
+    my ($x) = @_;
+    our (@get_tree_memo, %get_tree_memo);
+    my $memo = $get_tree_memo{$x};
+    return @$memo if $memo;
+
+    local $debugcmd_when_debuglevel = 3;
+    my @l;
+    my @cmd = (qw(git ls-tree -z --full-tree --), $x);
+    my $o = cmdoutput @cmd;
+    $o =~ s/\0$//s;
+    my $last = '';
+    foreach my $l (split /\0/, $o) {
+       my ($i, $n) = split /\t/, $l, 2;
+       $n .= '/' if $i =~ m/^\d+ tree /;
+       push @l, [ $n, $i ];
+       confess "$x need $last < $n ?" unless $last lt $n;
+    }
+    $get_tree_memo{$x} = \@l;
+    push @get_tree_memo, $x;
+    if (@get_tree_memo > 10) {
+       delete $get_tree_memo{ shift @get_tree_memo };
+    }
+    return @l;
+}
+
+sub trees_diff_walk ($$$;$) {
+    # trees_diff_walk [$all,] $x, $y, sub {... }
+    # calls sub->($name, $ix, $iy) for each difference (with $all, each name)
+    # $x and $y are as for get_tree
+    # where $name, $ix, $iy are $name and $info from get_tree
+    my $all = shift @_ if @_>=4;
+    my ($x,$y,$call) = @_;
+    return if !$all and $x eq $y;
+    my @x = get_tree $x;
+    my @y = get_tree $y;
+    while (@x || @y) {
+       my $cmp = !@x       <=> !@y          # eg @y empty? $cmp=-1, use x
+            ||    $x[0][0] cmp  $y[0][0];   # eg, x lt y ? $cmp=-1, use x
+       my ($n, $ix, $iy);                   # all same? $cmp=0, use both
+       $ix=$iy='';
+       ($n, $ix) = @{ shift @x } if $cmp <= 0;
+       ($n, $iy) = @{ shift @y } if $cmp >= 0;
+       next if !$all and $ix eq $iy;
+       printdebug sprintf
+           "trees_diff_walk(%d,'%s','%s') call('%s','%s','%s')\n",
+           !!$all,$x,$y, $n,$ix,$iy
+           if $debuglevel >= 2;
+       $call->($n, $ix, $iy);
+    }
+}
+
 sub get_differs ($$) {
     my ($x,$y) = @_;
     # This resembles quiltify_trees_differ, in dgit, a bit.
@@ -1434,17 +1492,11 @@ sub walk ($;$$$) {
     in_workarea sub {
        mkdir $rd or $!==EEXIST or die $!;
        my $current_method;
-       runcmd @git, qw(read-tree), $build;
+       my $want_debian = $build;
+       my $want_upstream = $build;
 
-       my $read_tree_upstream = sub {
-           my ($treeish) = @_;
-           read_tree_upstream $treeish, 0, $build;
-       };
-
-       my $read_tree_debian = sub {
-           my ($treeish) = @_;
-           read_tree_debian($treeish);
-       };
+       my $read_tree_upstream = sub { ($want_upstream) = @_; };
+       my $read_tree_debian = sub { ($want_debian) = @_; };
 
        foreach my $cl (qw(Debian), (reverse @brw_cl),
                        { SpecialMethod => 'RecordBreakwaterTip' },
@@ -1533,27 +1585,34 @@ sub walk ($;$$$) {
                    printdebug "WALK REWRITING NOW cl=$cl procd=$procd\n";
                }
            }
-           my $newtree = cmdoutput @git, qw(write-tree);
-           my $ch = $cl->{Hdr};
-           $ch =~ s{^tree .*}{tree $newtree}m or confess "$ch ?";
-           $ch =~ s{^parent .*\n}{}mg;
-           $ch =~ s{(?=^author)}{
-               join '', map { "parent $_\n" } @parents
-           }me or confess "$ch ?";
-           if ($rewriting) {
-               $ch =~ s{^committer .*$}{$committer_authline}m
-                   or confess "$ch ?";
+           if ($rewriting || $opt_careful) {
+               read_tree_upstream $want_upstream, 0, $want_debian;
+
+               my $newtree = cmdoutput @git, qw(write-tree);
+               my $ch = $cl->{Hdr};
+               $ch =~ s{^tree .*}{tree $newtree}m or confess "$ch ?";
+               $ch =~ s{^parent .*\n}{}mg;
+               $ch =~ s{(?=^author)}{
+                   join '', map { "parent $_\n" } @parents
+               }me or confess "$ch ?";
+               if ($rewriting) {
+                   $ch =~ s{^committer .*$}{$committer_authline}m
+                       or confess "$ch ?";
+               }
+               my $cf = "$rd/m$rewriting";
+               open CD, ">", $cf or die $!;
+               print CD $ch, "\n", $cl->{Msg} or die $!;
+               close CD or die $!;
+               my @cmd = (@git, qw(hash-object));
+               push @cmd, qw(-w) if $rewriting;
+               push @cmd, qw(-t commit), $cf;
+               my $newcommit = cmdoutput @cmd;
+               confess "$ch ?" unless $rewriting
+                   or $newcommit eq $cl->{CommitId};
+               $build = $newcommit;
+           } else {
+               $build = $cl->{CommitId};
            }
-           my $cf = "$rd/m$rewriting";
-           open CD, ">", $cf or die $!;
-           print CD $ch, "\n", $cl->{Msg} or die $!;
-           close CD or die $!;
-           my @cmd = (@git, qw(hash-object));
-           push @cmd, qw(-w) if $rewriting;
-           push @cmd, qw(-t commit), $cf;
-           my $newcommit = cmdoutput @cmd;
-           confess "$ch ?" unless $rewriting or $newcommit eq $cl->{CommitId};
-           $build = $newcommit;
             if (grep { $method eq $_ } qw(DgitImportUpstreamUpdate)) {
                 $last_anchor = $cur;
             }