coreutils/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(
    arch b2sum base32 base64 basenc nbasename cat chcon chgrp chmod chown
    chroot cksum comm cp csplit cut date dd df dir dircolors dirname du echo
    env expand expr factor false fmt fold groups head hostid hostname id
    install join kill link ln logname ls md5sum mkdir mkfifo mknod mktemp
    mv nice nl nohup nproc numfmt od paste pathchk pinky pr printenv printf
    ptx pwd readlink realpath rm rmdir runcon seq sha1sum sha224sum sha256sum
    sha384sum sha512sum shred shuf sleep sort split stat stdbuf stty
    sum sync tac tail tee test timeout touch tr true truncate tsort
    tty uname unexpand uniq unlink uptime users vdir wc who whoami yes

    all copy gnulib tests maint doc build scripts sha\*sum
    );
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, '<', $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.
  foreach my $line (@line)
    {
      72 < length $line && $line =~ /^[^#]/
        and return 'line longer than 72';
    }

  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";

  $buf =~ /^ *Signed-off-by:/mi
    and return q(do not use "Signed-off-by:");

  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";
      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;
    }
}