What's cooking (2013/03 #03)
[alt-git.git] / RR.perl
blob575aa1cfbcac2f6a170fa0416e4a02bf427c0ff4
1 #!/usr/bin/perl
3 # This is an attempt to cache earlier hand resolve of conflicting
4 # merges and reuse them when applicable.
6 # The flow roughly goes like this:
8 # $ git pull . test
9 # Auto-merging frotz
10 # fatal: merge program failed
11 # Automatic merge failed; fix up by hand
12 # $ git rere
13 # Recorded preimage for 'frotz'
14 # $ edit frotz ;# resolve by hand
15 # $ git rere
16 # Recorded resolution for 'frotz'
17 # $ build/test/have fun
18 # $ git reset --hard ;# decide to keep working
19 # $ ... ;# maybe even make more commits on "master"
21 # Later
23 # $ git pull . test
24 # Auto-merging frotz
25 # fatal: merge program failed
26 # Automatic merge failed; fix up by hand
27 # $ git rere
28 # Resolved 'frotz' using previous resolution.
31 use Digest;
32 use File::Path;
33 use File::Copy;
35 my $git_dir = $::ENV{GIT_DIR} || ".git";
36 my $rr_dir = "$git_dir/rr-cache";
37 my $merge_rr = "$git_dir/rr-cache/MERGE_RR";
39 my %merge_rr = ();
41 sub read_rr {
42 if (!-f $merge_rr) {
43 %merge_rr = ();
44 return;
46 my $in;
47 local $/ = "\0";
48 open $in, "<$merge_rr" or die "$!: $merge_rr";
49 while (<$in>) {
50 chomp;
51 my ($name, $path) = /^([0-9a-f]{40})\t(.*)$/s;
52 $merge_rr{$path} = $name;
54 close $in;
57 sub write_rr {
58 my $out;
59 open $out, ">$merge_rr" or die "$!: $merge_rr";
60 for my $path (sort keys %merge_rr) {
61 my $name = $merge_rr{$path};
62 print $out "$name\t$path\0";
64 close $out;
67 sub compute_conflict_name {
68 my ($path) = @_;
69 my @side = ();
70 my $in;
71 open $in, "<$path" or die "$!: $path";
73 my $sha1 = Digest->new("SHA-1");
74 my $hunk = 0;
75 while (<$in>) {
76 if (/^<<<<<<< .*/) {
77 $hunk++;
78 @side = ([], undef);
80 elsif (/^=======$/) {
81 $side[1] = [];
83 elsif (/^>>>>>>> .*/) {
84 my ($one, $two);
85 $one = join('', @{$side[0]});
86 $two = join('', @{$side[1]});
87 if ($two le $one) {
88 ($one, $two) = ($two, $one);
90 $sha1->add($one);
91 $sha1->add("\0");
92 $sha1->add($two);
93 $sha1->add("\0");
94 @side = ();
96 elsif (@side == 0) {
97 next;
99 elsif (defined $side[1]) {
100 push @{$side[1]}, $_;
102 else {
103 push @{$side[0]}, $_;
106 close $in;
107 return ($sha1->hexdigest, $hunk);
110 sub record_preimage {
111 my ($path, $name) = @_;
112 my @side = ();
113 my ($in, $out);
114 open $in, "<$path" or die "$!: $path";
115 open $out, ">$name" or die "$!: $name";
117 while (<$in>) {
118 if (/^<<<<<<< .*/) {
119 @side = ([], undef);
121 elsif (/^=======$/) {
122 $side[1] = [];
124 elsif (/^>>>>>>> .*/) {
125 my ($one, $two);
126 $one = join('', @{$side[0]});
127 $two = join('', @{$side[1]});
128 if ($two le $one) {
129 ($one, $two) = ($two, $one);
131 print $out "<<<<<<<\n";
132 print $out $one;
133 print $out "=======\n";
134 print $out $two;
135 print $out ">>>>>>>\n";
136 @side = ();
138 elsif (@side == 0) {
139 print $out $_;
141 elsif (defined $side[1]) {
142 push @{$side[1]}, $_;
144 else {
145 push @{$side[0]}, $_;
148 close $out;
149 close $in;
152 sub find_conflict {
153 my $in;
154 local $/ = "\0";
155 open $in, '-|', qw(git ls-files -z -u) or die "$!: ls-files";
156 my %path = ();
157 my @path = ();
158 while (<$in>) {
159 chomp;
160 my ($mode, $sha1, $stage, $path) =
161 /^([0-7]+) ([0-9a-f]{40}) ([123])\t(.*)$/s;
162 $path{$path} |= (1 << $stage);
164 close $in;
165 while (my ($path, $status) = each %path) {
166 if ($status == 14) { push @path, $path; }
168 return @path;
171 sub merge {
172 my ($name, $path) = @_;
173 record_preimage($path, "$rr_dir/$name/thisimage");
174 unless (system('merge', map { "$rr_dir/$name/${_}image" }
175 qw(this pre post))) {
176 my $in;
177 open $in, "<$rr_dir/$name/thisimage" or
178 die "$!: $name/thisimage";
179 my $out;
180 open $out, ">$path" or die "$!: $path";
181 while (<$in>) { print $out $_; }
182 close $in;
183 close $out;
184 return 1;
186 return 0;
189 -d "$rr_dir" || exit(0);
191 read_rr();
192 my %conflict = map { $_ => 1 } find_conflict();
194 # MERGE_RR records paths with conflicts immediately after merge
195 # failed. Some of the conflicted paths might have been hand resolved
196 # in the working tree since then, but the initial run would catch all
197 # and register their preimages.
199 for my $path (keys %conflict) {
200 # This path has conflict. If it is not recorded yet,
201 # record the pre-image.
202 if (!exists $merge_rr{$path}) {
203 my ($name, $hunk) = compute_conflict_name($path);
204 next unless ($hunk);
205 $merge_rr{$path} = $name;
206 if (! -d "$rr_dir/$name") {
207 mkpath("$rr_dir/$name", 0, 0777);
208 print STDERR "Recorded preimage for '$path'\n";
209 record_preimage($path, "$rr_dir/$name/preimage");
214 # Now some of the paths that had conflicts earlier might have been
215 # hand resolved. Others may be similar to a conflict already that
216 # was resolved before.
218 for my $path (keys %merge_rr) {
219 my $name = $merge_rr{$path};
221 # We could resolve this automatically if we have images.
222 if (-f "$rr_dir/$name/preimage" &&
223 -f "$rr_dir/$name/postimage") {
224 if (merge($name, $path)) {
225 print STDERR "Resolved '$path' using previous resolution.\n";
226 # Then we do not have to worry about this path
227 # anymore.
228 delete $merge_rr{$path};
229 next;
233 # Let's see if we have resolved it.
234 (undef, my $hunk) = compute_conflict_name($path);
235 next if ($hunk);
237 print STDERR "Recorded resolution for '$path'.\n";
238 copy($path, "$rr_dir/$name/postimage");
239 # And we do not have to worry about this path anymore.
240 delete $merge_rr{$path};
243 # Write out the rest.
244 write_rr();