bump Module::Build in Maintainers.pl
[perl.git] / Porting / mergelog-tool
1 #!/usr/bin/perl
2 #
3 # mergelog-tool, DAPM 15-Feb-2009
4 #
5 # Process metadata records stored in a text file that concern merges
6 # between bleed and maint perl
7
8 use 5.010;
9
10 use warnings;
11 use strict;
12
13 use Getopt::Std;
14
15 my $SHA_LEN = 10; # how many characters in the shortened SHA-1 hash
16
17 my %STATUS = (
18     'M' => 'Fully merged',
19     'P' => 'Partally merged, the rest rejected',
20     'R' => 'Fully rejected',
21     'A' => 'part of branch merged in single Aggregate merge',
22     'd' => 'Defer until a later release',
23     'm' => 'Partally merged, the rest pending',
24     '!' => 'Reviewed but awaiting action',
25     '.' => 'Unreviewed',
26 );
27
28
29 my %OPTS;
30
31 sub usage { die <<EOF; }
32 usage: $0 [-ch] [-f record_file] -c|-m|-u
33     -c         just check syntax of record file
34     -f file    name of record file
35     -h         help
36     -M         Directory in which to create mailboxes
37     -m         generate mailboxes (in current directory by default)
38     -u         update log file with latest commits (previous renamed .bak)
39 EOF
40
41 getopts('cf:hM:mu', \%OPTS) or usage;
42 usage if $OPTS{h};
43
44 my $action = join '', map $OPTS{$_} ? $_ : '', qw(c m u);
45 die "The action must be one of -c, -m, -u\n" unless $action =~ /^[cmu]$/;
46
47 my $record_filename = $OPTS{f} // "Porting/mergelog";
48
49 {
50     my ($records, $index) = read_merge_record_file($record_filename);
51     exit 0 if $action eq 'c';
52
53     if ($action eq 'm') {
54         generate_mailboxes($records, $index, ($OPTS{M} // '.'));
55         exit 0;
56     }
57
58     if ($action eq 'u') {
59         update_record_file($records, $index, $record_filename);
60     }
61 }
62
63
64
65 exit 0;
66
67
68 # given a file name, read in the merge record file and return
69 # an array of records and an index of commit ids that link to records in
70 # that array.
71 #
72 # Comment records and line continutions are captured in such a way
73 # that it should be possible to exactly regenerate the original file
74 # (apart from minor whitespace differences).
75
76 sub read_merge_record_file {
77     my ($file) = @_;
78
79     open my $fh, '<', $file
80         or die "$0: Can't open '$file': $!\n";
81
82     my %index;
83     my @records;
84     while (<$fh>) {
85         if ($. == 1 or /^\S/) {
86             # new entry
87             if (/^#/) {
88                 # comment
89                 push @records, [ '#', undef, undef, $' ];
90                 next;
91             }
92             my ($flag, $commit, $date, $rest) = split ' ', $_, 4;
93             defined $rest
94                 or die "$0: malformed line at $file:$.:\n$_";
95             $flag =~ /^[AMPRdm!\.]$/
96                 or die "$0: unrecognised flag '$flag' at $file:$.\n";
97             $commit =~ /^[0-9a-f]{$SHA_LEN}$/
98                 or die "$0: badly-formed commit '$commit' at $file:$.\n";
99             $index{$commit} and
100                 die "Duplicate commit '$commit' at $file:$.\n";
101             push @records, [ $flag, $commit, $date, $rest ];
102             $index{$commit} = $records[-1];
103         }
104         else {
105             # continuation line
106             if ( (($records[-1][0] // '') eq '#') and /\S/) {
107                 die
108                 "$0: illegal continuation line after comment at $file:$.:\n$_";
109             }
110             $records[-1][-1] .= $_;
111         }
112     }
113     chomp $_->[3] for @records;
114     return \@records, \%index;
115 }
116
117 # given a ref to a record array, and a file handle, write the records out
118 #
119 sub write_merge_record_file {
120     my ($records, $fh) = @_;
121     for my $record (@$records) {
122         if ($record->[0] eq '#') {
123             print $fh @$record[0,3], "\n";;
124         }
125         else {
126             printf $fh "%s  %s %s %s\n", @$record;
127         }
128     }
129 }
130
131
132 # get a list of commit records based on the passed format and args.
133 # Format should start with %H. $fieldcount is the expected number
134 # of fields per record.
135 #
136 # Returns both a hash and a list
137  
138 sub get_commits {
139     my ($format, $args, $fieldcount) = @_;
140
141     # XXX make this depend on current branch rather than hard-coding???
142     my $range = "perl-5.10.0..origin/blead";
143
144
145     # Initially I just used \x00 as a record separator, but at least one
146     # diff had a null char in it! (5254b38e) So add some extra text too
147     my $SEP = 'RjqenKHPaNJq';
148
149     open my $log, "git log $args --pretty=format:'%x00$SEP$format' $range|"
150         or die "$0: failed to execute 'git log': $!\n";
151
152
153     my %commits;
154     my @commits;
155     {
156         local $/ = "\x00$SEP";
157         while (<$log>) {
158             chomp;
159             next unless length; # skip first null record
160             my $rec = [ split /\x01/, $_];
161             die "$0: unexpected commit field count: ", scalar(@$rec), "\n"
162                 if @$rec != $fieldcount;
163             my $short = substr($rec->[0], 0, $SHA_LEN);
164             if (exists $commits{$short}) {
165                 die <<EOF;
166 $0: Internal error: duplicate short commit found: '$short'.
167 This means that the shortened SHA-1 hashes in the log file are no longer
168 long enough. The log file will need altering and this script modified
169 before you can proceed.
170 EOF
171             }
172             $commits{$short} = $rec;
173             push @commits, $rec;
174         }
175     }
176
177     close $log;
178     return \%commits, [ reverse @commits ];
179 }
180
181
182 # Create three mailboxes  in the given directory, containing accepted
183 # rejected and pending changes
184
185 sub generate_mailboxes {
186     my ($records, $index, $dir) = @_;
187
188     die "$0: No such directory: '$dir'\n" unless -d $dir;
189
190     my %mboxes;
191     for (qw(accepted rejected pending)) {
192         my $f = "$dir/p5c_$_";
193         my $fh;
194         open $fh, '>', $f or die "$0: failed to create '$f': $!\n";
195         $mboxes{$_} = $fh;
196     }
197
198     my ($commits) = get_commits(
199         '%H%x01%an%x01%ae%x01%aD%x01%ce%x01%cD%x01%s%x01%b%x01%P%x01',
200          '--stat -p -M', 10);
201
202     my %counts;
203     my $status;
204     my $linesep = '=' x 70;
205
206     for my $record (@$records) {
207         next if $record->[0] eq '#';
208
209         $status = "Status: RO\n"; # email is read and old
210
211         my $fh;
212         if ($record->[0] =~ /^[AMP]$/) {
213             $fh = $mboxes{accepted};
214             $counts{accepted}++;
215         }
216         elsif ($record->[0] =~ /^[dR]$/) {
217             $fh = $mboxes{rejected};
218             $counts{rejected}++;
219         }
220         elsif ($record->[0] =~ /^[m!\.]$/) {
221             $fh = $mboxes{pending};
222             $counts{pending}++;
223             $status = '' if $record->[0] eq '.'; # mark email as new
224         }
225         else {
226             die "$0: Unexpected flag type '$record->[0]'\n";
227         }
228
229         # $commit arrays contain:
230         #    0 commit SHA1
231         #    1 Author Name
232         #    2 Author Email
233         #    3 Author Date (RFC822)
234         #    4 Committer Email
235         #    5 Committer Date (RFC822)
236         #    6 Subject
237         #    7 Body
238         #    8 parents
239         #    9 File list and diff (--stat -p)
240
241         my $shortsha1 = $record->[1];
242         my $c =  $commits->{$shortsha1};
243         die "$0: Unknown commit '$shortsha1'\n" unless $c;
244
245
246         
247         my $subj = "$record->[0] $shortsha1 "
248             # a slight subterfuge here to avoid three X's in this src
249             . (($record->[3] =~ /[X]XX/) ? 'X'.'XX ' : '') . ($c->[6] // '');
250
251         my $cdate = $c->[5];
252         # convert RFC822 date into mbox 'From ' header format
253         #             Fri, 20 Feb 2009 14:45:36 +0100
254         #             Wed Jan  9 19:47:43 2008
255         $cdate =~ s/ [+\-]\d{4}$//;
256         $cdate =~ s{^(\w\w\w),(\s+\d+) (\w\w\w) (\d{4}) ([\d:]{8})$}
257                     {$1 $3$2 $5 $4}
258             or die "$0: Can't convert RFC822 date: '$cdate'\n";
259
260         my @parents = map substr($_,0,$SHA_LEN), split ' ', $c->[8];
261         my $merged = @parents > 1 ? "MERGED: @parents\n" : '';
262
263         my $files_and_diff = $c->[9];
264         $files_and_diff =~ s/^---/\n---\n/;
265         $files_and_diff =~ s/^( \d+ files changed,)/\n$1/m;
266         $files_and_diff =~ s/^diff /$linesep\n\ndiff /m;
267
268         # truncate long bodies
269
270         if (length($files_and_diff) > 100_000) {
271             substr($files_and_diff, 100_000) =
272                                     "\n\n***TRUNCATED at 100Kbytes\n";
273         }
274
275         my $body = <<EOF;
276 From: $c->[1] <$c->[2]>
277 Date: $c->[3]
278 Subject: $subj
279 Message-Id: <fake:$c->[0]>
280 $status
281 Commit: $c->[0]
282 Author: $c->[1] <$c->[2]>
283 Date:   $c->[3]
284 ${merged}Status: [$record->[0]] ($STATUS{$record->[0]})
285 Notes:  $record->[3]
286 $linesep
287
288 $c->[6]
289 $c->[7]
290 $files_and_diff
291 EOF
292
293         $body =~ s/^From />From /gm; # mbox 'From ' escaping
294         $body = "From $c->[4]  $cdate\n$body";
295
296         print $fh $body;
297     }
298     for (values %mboxes) {
299         close $_ or die "$0: close: $!\n";
300     }
301     for (qw(accepted rejected pending)) {
302         printf "%4d %s mailbox entries\n", $counts{$_}, $_;
303     }
304 }
305
306
307 sub update_record_file {
308     my ($records, $index, $record_filename) = @_;
309
310     my ($commit_hash, $commits) =
311         get_commits('%H%x01%P%x01%ct%x01%s', '', 4);
312
313     # confirm that commits is a superset of records
314     for (keys %$index) {
315         $commit_hash->{$_}
316             or die "$0: Entry '$_' in log file is not a recognised commit\n";
317     }
318
319     # convert git log output to log file format
320
321     for my $c (@$commits) {
322         my ($sha1, $parents, $date, $subject) = @$c;
323         $sha1 = substr($sha1, 0, $SHA_LEN);
324         my ($yy,$mm,$dd) = (gmtime($date))[5,4,3];
325         $date = sprintf "%04d/%02d/%02d", $yy+1900, $mm+1, $dd;
326         chomp $subject;
327         $subject = substr($subject, 0, 50);
328         my @parents = split ' ', $parents;
329         if (@parents > 1) {
330             $subject .= "\n\t\t\t\tMERGE: "
331                 . join ' ', map substr($_,0,$SHA_LEN), @parents;
332         }
333         @$c = ();
334         push @$c, '.', $sha1, $date, $subject;
335     }
336
337
338     # merge log file and new commits
339     
340     my @out;
341     COMMIT: for my $c (@$commits) {
342         while (1) {
343             my $r = $records->[0];
344             last unless $r;
345             if ($r->[0] eq '#') {
346                 push @out, $r;
347                 shift @$records;
348                 next;
349             }
350
351             if ($r->[1] eq $c->[1]) {
352                 push @out, $r;
353                 shift @$records;
354                 next COMMIT;
355             }
356             last;
357         }
358         push @out, $c;
359     }
360     @$records and die
361         "$0: Internal error: unexpected log records left after merge\n";
362
363
364     my $new = "$record_filename.new";
365     my $bak = "$record_filename.bak";
366
367     die "$0: $new already exists\n" if -e $new;
368     open my $out, '>', $new
369         or die "$0: Can't create '$new': $!\n";
370     write_merge_record_file(\@out,$out);
371     close $out
372         or die "$0: close($new): $!\n";
373     -s $new < -s $record_filename
374         and die "$0: new file '$new' is smaller than existing file\n";
375     rename $record_filename, $bak
376         or die "$0: rename $record_filename -> $bak: $!\n";
377     rename $new, $record_filename
378         or die "$0: rename $new -> $record_filename: $!\n";
379 }