scripts/git-hooks/commit-msg

   1 eval '(exit $?0)' && eval 'exec perl -w "$0" ${1+"$@"}'
   2   & eval 'exec perl -w "$0" $argv:q'
   3     if 0;
   4
   5 use strict;
   6 use warnings;
   7 (my $ME = $0) =~ s|.*/||;
   8
   9 # Emulate Git's choice of the editor for the commit message.
  10 chomp (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.
  16 my @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     );
  29 my $v_or = join '|', @valid;
  30 my $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.
  34 sub 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
  46 sub 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
  57 sub 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.
  85 sub 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 }