diffutils/scripts/git-hooks/commit-msg

eval '(exit $?0)' && eval 'exec perl -w "$0" ${1+"$@"}'
  & eval 'exec perl -w "$0" $argv:q'
    if 0;

use strict;
use warnings;
(my $ME = $0) =~ s|.*/||;

# Emulate Git's choice of the editor for the commit message.
chomp (my $editor = `git var GIT_EDITOR`);
# And have a sane, minimal fallback in case of weird failures.
$editor = "vi" if $? != 0 or $editor =~ /^\s*\z/;

# Keywords allowed before the colon on the first line of a commit message:
# program names and a few general category names.
my @valid = qw(
    diff diff3 cmp sdiff

    all gnulib tests maint doc build scripts
    );
my $v_or = join '|', @valid;
my $valid_regex = qr/^(?:$v_or)$/;

# Rewrite the $LOG_FILE (old contents in @$LINE_REF) with an additional
# a commented diagnostic "# $ERR" line at the top.
sub rewrite($$$)
{
  my ($log_file, $err, $line_ref) = @_;
  local *LOG;
  open LOG, '>', $log_file
    or die "$ME: $log_file: failed to open for writing: $!";
  print LOG "# $err";
  print LOG @$line_ref;
  close LOG
    or die "$ME: $log_file: failed to rewrite: $!\n";
}

sub re_edit($)
{
  my ($log_file) = @_;

  warn "Interrupt (Ctrl-C) to abort...\n";

  system 'sh', '-c', "$editor $log_file";
  ($? & 127) || ($? >> 8)
    and die "$ME: $log_file: the editor ($editor) failed, aborting\n";
}

sub bad_first_line($)
{
  my ($line) = @_;

  $line =~ /^[Vv]ersion \d/
    and return '';

  $line =~ /:/
    or return 'missing colon on first line of log message';

  $line =~ /\.$/
    and return 'do not use a period "." at the end of the first line';

  # The token(s) before the colon on the first line must be on our list
  # Tokens may be space- or comma-separated.
  (my $pre_colon = $line) =~ s/:.*//;
  my @word = split (/[ ,]/, $pre_colon);
  my @bad = grep !/$valid_regex/, @word;
  @bad
    and return 'invalid first word(s) of summary line: ' . join (', ', @bad);

  return '';
}

# Given a $LOG_FILE name and a \@LINE buffer,
# read the contents of the file into the buffer and analyze it.
# If the log message passes muster, return the empty string.
# If not, return a diagnostic.
sub check_msg($$)
{
  my ($log_file, $line_ref) = @_;

  local *LOG;
  open LOG, '<:utf8', $log_file
    or return "failed to open for reading: $!";
  @$line_ref = <LOG>;
  close LOG;

  my @line = @$line_ref;
  chomp @line;

  # Don't filter out blank or comment lines; git does that already,
  # and if we were to ignore them here, it could lead to committing
  # with lines that start with "#" in the log.

  # Filter out leading blank and comment lines.
  # while (@line && $line[0] =~ /^(?:#.*|[ \t]*)$/) { shift @line; }

  # Filter out blank and comment lines at EOF.
  # while (@line && $line[$#line] =~ /^(?:#.*|[ \t]*)$/) { pop @line; }

  @line == 0
    and return 'no log message';

  my $bad = bad_first_line $line[0];
  $bad
    and return $bad;

  # Second line should be blank or not present.
  2 <= @line && length $line[1]
    and return 'second line must be empty';

  # Limit line length to allow for the ChangeLog's leading TAB.
  my $max_len = 72;
  foreach my $line (@line)
    {
      last if $line =~ '.*-{24} >8 -{24}$';
      my $len = length $line;
      $max_len < $len && $line =~ /^[^#]/
        and return "line length ($len) greater than than max: $max_len";
    }

  my $buf = join ("\n", @line) . "\n";
  $buf =~ m!https?://bugzilla\.redhat\.com/show_bug\.cgi\?id=(\d+)!s
    and return "use shorter https://bugzilla.redhat.com/$1";

  $buf =~ m!https?://debbugs\.gnu\.org/(?:cgi/bugreport\.cgi\?bug=)?(\d+)!s
    and return "use shorter https://bugs.gnu.org/$1";

  $buf =~ m!https://lists\.gnu\.org/archive/html/!s
    and return "use '/r/' in place of '/archive/html/' in lists.gnu.org URLs";

  return '';
}

{
  @ARGV == 1
    or die;

  my $log_file = $ARGV[0];

  while (1)
    {
      my @line;
      my $err = check_msg $log_file, \@line;
      $err eq ''
        and last;
      $err = "$ME: $err\n";
      -t STDOUT or die $err;
      warn $err;
      # Insert the diagnostic as a comment on the first line of $log_file.
      rewrite $log_file, $err, \@line;
      re_edit $log_file;

      # Stop if our parent is killed.
      getppid() == 1
        and last;
    }
}