1eval '(exit $?0)' && eval 'exec perl -w "$0" ${1+"$@"}'
2  & eval 'exec perl -w "$0" $argv:q'
3    if 0;
4
5use strict;
6use warnings;
7(my $ME = $0) =~ s|.*/||;
8
9# Emulate Git's choice of the editor for the commit message.
10chomp (my $editor = `git var GIT_EDITOR`);
11# And have a sane, minimal fallback in case of weird failures.
12$editor = "vi" if $? != 0 or $editor =~ /^\s*\z/;
13
14# Keywords allowed before the colon on the first line of a commit message:
15# program names and a few general category names.
16my @valid = qw(
17    arch b2sum base32 base64 basenc basename cat chcon chgrp chmod chown
18    chroot cksum comm cp csplit cut date dd df dir dircolors dirname du echo
19    env expand expr factor false fmt fold groups head hostid hostname id
20    install join kill link ln logname ls md5sum mkdir mkfifo mknod mktemp
21    mv nice nl nohup nproc numfmt od paste pathchk pinky pr printenv printf
22    ptx pwd readlink realpath rm rmdir runcon seq sha1sum sha224sum sha256sum
23    sha384sum sha512sum shred shuf sleep sort split stat stdbuf stty
24    sum sync tac tail tee test timeout touch tr true truncate tsort
25    tty uname unexpand uniq unlink uptime users vdir wc who whoami yes
26
27    all copy gnulib tests maint doc build scripts sha\*sum digest
28    );
29my $v_or = join '|', @valid;
30my $valid_regex = qr/^(?:$v_or)$/;
31
32# Rewrite the $LOG_FILE (old contents in @$LINE_REF) with an additional
33# a commented diagnostic "# $ERR" line at the top.
34sub rewrite($$$)
35{
36  my ($log_file, $err, $line_ref) = @_;
37  local *LOG;
38  open LOG, '>', $log_file
39    or die "$ME: $log_file: failed to open for writing: $!";
40  print LOG "# $err";
41  print LOG @$line_ref;
42  close LOG
43    or die "$ME: $log_file: failed to rewrite: $!\n";
44}
45
46sub re_edit($)
47{
48  my ($log_file) = @_;
49
50  warn "Interrupt (Ctrl-C) to abort...\n";
51
52  system 'sh', '-c', "$editor $log_file";
53  ($? & 127) || ($? >> 8)
54    and die "$ME: $log_file: the editor ($editor) failed, aborting\n";
55}
56
57sub bad_first_line($)
58{
59  my ($line) = @_;
60
61  $line =~ /^[Vv]ersion \d/
62    and return '';
63
64  $line =~ /:/
65    or return 'missing colon on first line of log message';
66
67  $line =~ /\.$/
68    and return 'do not use a period "." at the end of the first line';
69
70  # The token(s) before the colon on the first line must be on our list
71  # Tokens may be space- or comma-separated.
72  (my $pre_colon = $line) =~ s/:.*//;
73  my @word = split (/[ ,]/, $pre_colon);
74  my @bad = grep !/$valid_regex/, @word;
75  @bad
76    and return 'invalid first word(s) of summary line: ' . join (', ', @bad);
77
78  return '';
79}
80
81# Given a $LOG_FILE name and a \@LINE buffer,
82# read the contents of the file into the buffer and analyze it.
83# If the log message passes muster, return the empty string.
84# If not, return a diagnostic.
85sub check_msg($$)
86{
87  my ($log_file, $line_ref) = @_;
88
89  local *LOG;
90  open LOG, '<:utf8', $log_file
91    or return "failed to open for reading: $!";
92  @$line_ref = <LOG>;
93  close LOG;
94
95  my @line = @$line_ref;
96  chomp @line;
97
98  # Don't filter out blank or comment lines; git does that already,
99  # and if we were to ignore them here, it could lead to committing
100  # with lines that start with "#" in the log.
101
102  # Filter out leading blank and comment lines.
103  # while (@line && $line[0] =~ /^(?:#.*|[ \t]*)$/) { shift @line; }
104
105  # Filter out blank and comment lines at EOF.
106  # while (@line && $line[$#line] =~ /^(?:#.*|[ \t]*)$/) { pop @line; }
107
108  @line == 0
109    and return 'no log message';
110
111  my $bad = bad_first_line $line[0];
112  $bad
113    and return $bad;
114
115  # Second line should be blank or not present.
116  2 <= @line && length $line[1]
117    and return 'second line must be empty';
118
119  # Limit line length to allow for the ChangeLog's leading TAB.
120  my $max_len = 72;
121  foreach my $line (@line)
122    {
123      last if $line =~ '.*-{24} >8 -{24}$';
124      my $len = length $line;
125      $max_len < $len && $line =~ /^[^#]/
126        and return "line length ($len) greater than than max: $max_len";
127    }
128
129  my $buf = join ("\n", @line) . "\n";
130  $buf =~ m!https?://bugzilla\.redhat\.com/show_bug\.cgi\?id=(\d+)!s
131    and return "use shorter https://bugzilla.redhat.com/$1";
132
133  $buf =~ m!https?://debbugs\.gnu\.org/(?:cgi/bugreport\.cgi\?bug=)?(\d+)!s
134    and return "use shorter https://bugs.gnu.org/$1";
135
136  $buf =~ m!https://lists\.gnu\.org/archive/html/!s
137    and return "use '/r/' in place of '/archive/html/' in lists.gnu.org URLs";
138
139  return '';
140}
141
142{
143  @ARGV == 1
144    or die;
145
146  my $log_file = $ARGV[0];
147
148  while (1)
149    {
150      my @line;
151      my $err = check_msg $log_file, \@line;
152      $err eq ''
153        and last;
154      $err = "$ME: $err\n";
155      -t STDOUT or die $err;
156      warn $err;
157      # Insert the diagnostic as a comment on the first line of $log_file.
158      rewrite $log_file, $err, \@line;
159      re_edit $log_file;
160
161      # Stop if our parent is killed.
162      getppid() == 1
163        and last;
164    }
165}
166