Merge branch 'fl/send-email-outside'
[git] / contrib / examples / git-rerere.perl
1 #!/usr/bin/perl
2 #
3 # REuse REcorded REsolve.  This tool records a conflicted automerge
4 # result and its hand resolution, and helps to resolve future
5 # automerge that results in the same conflict.
6 #
7 # To enable this feature, create a directory 'rr-cache' under your
8 # .git/ directory.
9
10 use Digest;
11 use File::Path;
12 use File::Copy;
13
14 my $git_dir = $::ENV{GIT_DIR} || ".git";
15 my $rr_dir = "$git_dir/rr-cache";
16 my $merge_rr = "$git_dir/rr-cache/MERGE_RR";
17
18 my %merge_rr = ();
19
20 sub read_rr {
21         if (!-f $merge_rr) {
22                 %merge_rr = ();
23                 return;
24         }
25         my $in;
26         local $/ = "\0";
27         open $in, "<$merge_rr" or die "$!: $merge_rr";
28         while (<$in>) {
29                 chomp;
30                 my ($name, $path) = /^([0-9a-f]{40})\t(.*)$/s;
31                 $merge_rr{$path} = $name;
32         }
33         close $in;
34 }
35
36 sub write_rr {
37         my $out;
38         open $out, ">$merge_rr" or die "$!: $merge_rr";
39         for my $path (sort keys %merge_rr) {
40                 my $name = $merge_rr{$path};
41                 print $out "$name\t$path\0";
42         }
43         close $out;
44 }
45
46 sub compute_conflict_name {
47         my ($path) = @_;
48         my @side = ();
49         my $in;
50         open $in, "<$path"  or die "$!: $path";
51
52         my $sha1 = Digest->new("SHA-1");
53         my $hunk = 0;
54         while (<$in>) {
55                 if (/^<<<<<<< .*/) {
56                         $hunk++;
57                         @side = ([], undef);
58                 }
59                 elsif (/^=======$/) {
60                         $side[1] = [];
61                 }
62                 elsif (/^>>>>>>> .*/) {
63                         my ($one, $two);
64                         $one = join('', @{$side[0]});
65                         $two = join('', @{$side[1]});
66                         if ($two le $one) {
67                                 ($one, $two) = ($two, $one);
68                         }
69                         $sha1->add($one);
70                         $sha1->add("\0");
71                         $sha1->add($two);
72                         $sha1->add("\0");
73                         @side = ();
74                 }
75                 elsif (@side == 0) {
76                         next;
77                 }
78                 elsif (defined $side[1]) {
79                         push @{$side[1]}, $_;
80                 }
81                 else {
82                         push @{$side[0]}, $_;
83                 }
84         }
85         close $in;
86         return ($sha1->hexdigest, $hunk);
87 }
88
89 sub record_preimage {
90         my ($path, $name) = @_;
91         my @side = ();
92         my ($in, $out);
93         open $in, "<$path"  or die "$!: $path";
94         open $out, ">$name" or die "$!: $name";
95
96         while (<$in>) {
97                 if (/^<<<<<<< .*/) {
98                         @side = ([], undef);
99                 }
100                 elsif (/^=======$/) {
101                         $side[1] = [];
102                 }
103                 elsif (/^>>>>>>> .*/) {
104                         my ($one, $two);
105                         $one = join('', @{$side[0]});
106                         $two = join('', @{$side[1]});
107                         if ($two le $one) {
108                                 ($one, $two) = ($two, $one);
109                         }
110                         print $out "<<<<<<<\n";
111                         print $out $one;
112                         print $out "=======\n";
113                         print $out $two;
114                         print $out ">>>>>>>\n";
115                         @side = ();
116                 }
117                 elsif (@side == 0) {
118                         print $out $_;
119                 }
120                 elsif (defined $side[1]) {
121                         push @{$side[1]}, $_;
122                 }
123                 else {
124                         push @{$side[0]}, $_;
125                 }
126         }
127         close $out;
128         close $in;
129 }
130
131 sub find_conflict {
132         my $in;
133         local $/ = "\0";
134         my $pid = open($in, '-|');
135         die "$!" unless defined $pid;
136         if (!$pid) {
137                 exec(qw(git ls-files -z -u)) or die "$!: ls-files";
138         }
139         my %path = ();
140         my @path = ();
141         while (<$in>) {
142                 chomp;
143                 my ($mode, $sha1, $stage, $path) =
144                     /^([0-7]+) ([0-9a-f]{40}) ([123])\t(.*)$/s;
145                 $path{$path} |= (1 << $stage);
146         }
147         close $in;
148         while (my ($path, $status) = each %path) {
149                 if ($status == 14) { push @path, $path; }
150         }
151         return @path;
152 }
153
154 sub merge {
155         my ($name, $path) = @_;
156         record_preimage($path, "$rr_dir/$name/thisimage");
157         unless (system('git', 'merge-file', map { "$rr_dir/$name/${_}image" }
158                        qw(this pre post))) {
159                 my $in;
160                 open $in, "<$rr_dir/$name/thisimage" or
161                     die "$!: $name/thisimage";
162                 my $out;
163                 open $out, ">$path" or die "$!: $path";
164                 while (<$in>) { print $out $_; }
165                 close $in;
166                 close $out;
167                 return 1;
168         }
169         return 0;
170 }
171
172 sub garbage_collect_rerere {
173         # We should allow specifying these from the command line and
174         # that is why the caller gives @ARGV to us, but I am lazy.
175
176         my $cutoff_noresolve = 15; # two weeks
177         my $cutoff_resolve = 60; # two months
178         my @to_remove;
179         while (<$rr_dir/*/preimage>) {
180                 my ($dir) = /^(.*)\/preimage$/;
181                 my $cutoff = ((-f "$dir/postimage")
182                               ? $cutoff_resolve
183                               : $cutoff_noresolve);
184                 my $age = -M "$_";
185                 if ($cutoff <= $age) {
186                         push @to_remove, $dir;
187                 }
188         }
189         if (@to_remove) {
190                 rmtree(\@to_remove);
191         }
192 }
193
194 -d "$rr_dir" || exit(0);
195
196 read_rr();
197
198 if (@ARGV) {
199         my $arg = shift @ARGV;
200         if ($arg eq 'clear') {
201                 for my $path (keys %merge_rr) {
202                         my $name = $merge_rr{$path};
203                         if (-d "$rr_dir/$name" &&
204                             ! -f "$rr_dir/$name/postimage") {
205                                 rmtree(["$rr_dir/$name"]);
206                         }
207                 }
208                 unlink $merge_rr;
209         }
210         elsif ($arg eq 'status') {
211                 for my $path (keys %merge_rr) {
212                         print $path, "\n";
213                 }
214         }
215         elsif ($arg eq 'diff') {
216                 for my $path (keys %merge_rr) {
217                         my $name = $merge_rr{$path};
218                         system('diff', ((@ARGV == 0) ? ('-u') : @ARGV),
219                                 '-L', "a/$path", '-L', "b/$path",
220                                 "$rr_dir/$name/preimage", $path);
221                 }
222         }
223         elsif ($arg eq 'gc') {
224                 garbage_collect_rerere(@ARGV);
225         }
226         else {
227                 die "$0 unknown command: $arg\n";
228         }
229         exit 0;
230 }
231
232 my %conflict = map { $_ => 1 } find_conflict();
233
234 # MERGE_RR records paths with conflicts immediately after merge
235 # failed.  Some of the conflicted paths might have been hand resolved
236 # in the working tree since then, but the initial run would catch all
237 # and register their preimages.
238
239 for my $path (keys %conflict) {
240         # This path has conflict.  If it is not recorded yet,
241         # record the pre-image.
242         if (!exists $merge_rr{$path}) {
243                 my ($name, $hunk) = compute_conflict_name($path);
244                 next unless ($hunk);
245                 $merge_rr{$path} = $name;
246                 if (! -d "$rr_dir/$name") {
247                         mkpath("$rr_dir/$name", 0, 0777);
248                         print STDERR "Recorded preimage for '$path'\n";
249                         record_preimage($path, "$rr_dir/$name/preimage");
250                 }
251         }
252 }
253
254 # Now some of the paths that had conflicts earlier might have been
255 # hand resolved.  Others may be similar to a conflict already that
256 # was resolved before.
257
258 for my $path (keys %merge_rr) {
259         my $name = $merge_rr{$path};
260
261         # We could resolve this automatically if we have images.
262         if (-f "$rr_dir/$name/preimage" &&
263             -f "$rr_dir/$name/postimage") {
264                 if (merge($name, $path)) {
265                         print STDERR "Resolved '$path' using previous resolution.\n";
266                         # Then we do not have to worry about this path
267                         # anymore.
268                         delete $merge_rr{$path};
269                         next;
270                 }
271         }
272
273         # Let's see if we have resolved it.
274         (undef, my $hunk) = compute_conflict_name($path);
275         next if ($hunk);
276
277         print STDERR "Recorded resolution for '$path'.\n";
278         copy($path, "$rr_dir/$name/postimage");
279         # And we do not have to worry about this path anymore.
280         delete $merge_rr{$path};
281 }
282
283 # Write out the rest.
284 write_rr();