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