File Coverage

blib/lib/Git/Hooks/CheckLog.pm

Criterion	Covered	Total	%
statement	31	135	22.9
branch	3	70	4.2
condition	0	34	0.0
subroutine	9	21	42.8
pod	0	10	0.0
total	43	270	15.9

use warnings;

package Git::Hooks::CheckLog;
# ABSTRACT: Git::Hooks plugin to enforce commit log policies
$Git::Hooks::CheckLog::VERSION = '3.4.0';
use v5.16.0;
use utf8;
use Log::Any '$log';
use Git::Hooks;
use Git::Message;
use List::MoreUtils qw/uniq/;

my $CFG = __PACKAGE__ =~ s/.*::/githooks./r;

#############
# Grok hook configuration, check it and set defaults.

sub _setup_config {
    my ($git) = @_;

    my $config = $git->get_config();

    $config->{lc $CFG} //= {};

    my $default = $config->{lc $CFG};
    $default->{'title-required'}  //= ['true'];
    $default->{'title-max-width'} //= [50];
    $default->{'title-period'}    //= ['deny'];
    $default->{'body-max-width'}  //= [72];

    return;
}

##########

# Return a Text::SpellChecker object or undef.

sub _spell_checker {
    my ($git, $msg) = @_;

    my %extra_options;

    if (my $lang = $git->get_config($CFG => 'spelling-lang')) {
        $extra_options{lang} = $lang;
    }

    unless (state $tried_to_check) {
        unless (eval { require Text::SpellChecker; }) {
            $git->fault(<<'EOS', {option => 'spelling', details => $@});
I could not load the Text::SpellChecker Perl module.

I need it to spell check your commit's messages as requested by this
configuration option.

Please, install the module or disable the option to proceed.
EOS
            return;
        }

        # Text::SpellChecker uses either Text::Hunspell or
        # Text::Aspell to perform the checks. But it doesn't try to
        # load those modules until we invoke its next_word method. So,
        # in order to detect errors in those modules we first create a
        # bogus Text::SpellChecker object and force it to spell a word
        # to see if it can go so far.

        my $checker = Text::SpellChecker->new(text => 'a', %extra_options);

        if (! defined eval { $checker->next_word(); } && $@) {
            $git->fault(<<'EOS', {option => 'spelling', details => $@});
There was an error while I tried to spell check your commits using the
Text::SpellChecker module. If you cannot fix it consider disabling this
your configuration option.
EOS
            return;
        }

        $tried_to_check = 1;
    }

    return Text::SpellChecker->new(text => $msg, %extra_options);
}

sub spelling_errors {
    my ($git, $id, $msg) = @_;

    return 0 unless $msg;

    return 0 unless $git->get_config_boolean($CFG => 'spelling');

    # Check all words comprised of at least three Unicode letters
    my $checker = _spell_checker($git, join("\n", uniq($msg =~ /\b(\p{Cased_Letter}{3,})\b/gi)))
        or return 1;

    my $errors = 0;

    foreach my $badword ($checker->next_word()) {
        my @suggestions = $checker->suggestions($badword);
        my %info = (option => 'spelling');
        $info{details} = join("\n  ", 'SUGGESTIONS:', @suggestions)
            if defined $suggestions[0];
        $git->fault("The commit $id log message has a misspelled word: '$badword'", \%info);
        ++$errors;
    }

    return $errors;
}

##########
# Perform a single pattern check and return the number of errors.

sub _pattern_error {
    my ($git, $text, $match, $what, $id) = @_;

    if ($match =~ s/^!\s*//) {
        $text !~ /$match/m
            or $git->fault("The commit log $what SHOULD NOT match '\Q$match\E'",
                           {commit => $id, option => 'match'})
            and return 1;
    }
    else {
        $text =~ /$match/m
            or $git->fault("The commit log $what SHOULD match '\Q$match\E'",
                           {commit => $id, option => 'match'})
            and return 1;
    }

    return 0;
}

sub pattern_errors {
    my ($git, $id, $msg) = @_;

    my $errors = 0;

    foreach my $match ($git->get_config($CFG => 'match')) {
        $errors += _pattern_error($git, $msg, $match, 'message', $id);
    }

    return $errors;
}

sub revert_errors {
    my ($git, $id, $msg) = @_;

    if ($git->get_config_boolean($CFG => 'deny-merge-revert')) {
        if ($msg =~ /This reverts commit ([0-9a-f]{40})/s) {
            # Get the reverted commit in an eval because it may be unreachable
            # now. In this case we simply don't care anymore.
            if (my $reverted_commit = eval {$git->get_commit($1)}) {
                if ($reverted_commit->parent() > 1) {
                    $git->fault(<<'EOS', {commit => $id, option => 'deny-merge-revert'});
This commit reverts a merge commit, which is not allowed
by your configuration option.
EOS
                    return 1;
                }
            }
        }
    }

    return 0;
}

sub title_errors {
    my ($git, $id, $title) = @_;

    unless (defined $title and length $title) {
        if ($git->get_config_boolean($CFG => 'title-required')) {
            $git->fault(<<'EOS', {commit => $id, option => 'title-required'});
This commit log message needs a title line.
This is required by your configuration option.
Please, amend your commit to add one.
EOS
            return 1;
        } else {
            return 0;
        }
    }

    ($title =~ tr/\n/\n/) == 1
        or $git->fault(<<'EOS', {commit => $id})
This commit log message title must have just one line.
Please amend your commit and edit its log message so that its first line
is separated from the rest by an empty line.
EOS
            and return 1;

    my $errors = 0;

    if (my $max_width = $git->get_config_integer($CFG => 'title-max-width')) {
        my $tlen = length($title) - 1; # discount the newline
        $tlen <= $max_width
            or $git->fault(<<"EOS", {commit => $id, option => 'title-max-width'})
This commit log message title is too long.
It is $tlen characters wide but should be at most $max_width, a limit set by
your configuration option.
Please, amend your commit to make its title shorter.
EOS
                and ++$errors;
    }

    if (my $period = $git->get_config($CFG => 'title-period')) {
        if ($period eq 'deny') {
            $title !~ /\.$/
                or $git->fault(<<'EOS', {commit => $id, option => 'title-period'})
This commit log message title SHOULD NOT end in a period.
This is required by your configuration option.
Please, amend your commit to remove the period.
EOS
                    and ++$errors;
        } elsif ($period eq 'require') {
            $title =~ /\.$/
                or $git->fault(<<'EOS', {commit => $id, option => 'title-period'})
This commit log message title SHOULD end in a period.
This is required by your configuration option.
Please, amend your commit to add the period.
EOS
                    and ++$errors;
        } elsif ($period ne 'allow') {
            $git->fault(<<"EOS", {commit => $id, option => 'title-period'})
Configuration error: invalid value '$period' for the configuration option.
The valid values are 'deny', 'allow', and 'require'.
EOS
                and ++$errors;
        }
    }

    foreach my $match ($git->get_config($CFG => 'title-match')) {
        $errors += _pattern_error($git, $title, $match, 'title', $id);
    }

    return $errors;
}

sub body_errors {
    my ($git, $id, $body) = @_;

    return 0 unless defined $body && length $body;

    if (my $max_width = $git->get_config_integer($CFG => 'body-max-width')) {
        if (my @biggies = grep {/^\S/} grep {length > $max_width} split(/\n/, $body)) {
            $git->fault(<<"EOS", {commit => $id, option => 'body-max-width', details => join("\n", @biggies)});
This commit log body has lines that are too long.
The configuration option limits body lines to $max_width characters.
But the following lines exceed it.
Please, amend your commit to make its lines shorter.
EOS
            return 1;
        }
    }

    return 0;
}

sub footer_errors {
    my ($git, $id, $cmsg) = @_;

    my $errors = 0;

    my @signed_off_by = $cmsg->get_footer_values('signed-off-by');

    if (@signed_off_by) {
        # Check for duplicate Signed-off-by footers
        my (%signed_off_by, @duplicates);
        foreach my $person (@signed_off_by) {
            $signed_off_by{$person} += 1;
            if ($signed_off_by{$person} == 2) {
                push @duplicates, $person;
            }
        }
        if (@duplicates) {
            $git->fault(<<'EOS', {commit => $id, details => join("\n", sort @duplicates)});
This commit have duplicate Signed-off-by footers.
Please, amend it to remove the duplicates:
EOS
            ++$errors;
        }
    } elsif ($git->get_config_boolean($CFG => 'signed-off-by')) {
        $git->fault(<<'EOS', {commit => $id, option => 'signed-off-by'});
This commit must have a Signed-off-by footer.
This is required by your configuration option.
Please, amend your commit to add it.
EOS
        ++$errors;
    }

    return $errors;
}

sub message_errors {
    my ($git, $commit, $msg) = @_;

    # assert(defined $msg)

    my $id = defined $commit ? $commit->commit : '';

    my $cmsg = Git::Message->new($msg);

    return
        spelling_errors($git, $id, $msg) +
        pattern_errors($git, $id, $msg) +
        revert_errors($git, $id, $msg) +
        title_errors($git, $id, $cmsg->title) +
        body_errors($git, $id, $cmsg->body) +
        footer_errors($git, $id, $cmsg);
}

sub check_message_file {
    my ($git, $msg) = @_;

    return message_errors($git, undef, $msg);
}

sub check_ref {
    my ($git, $ref) = @_;

    my $errors = 0;

    foreach my $commit ($git->get_affected_ref_commits($ref)) {
        $errors += message_errors($git, $commit, $commit->message);
    }

    return $errors;
}

sub check_patchset {
    my ($git, $branch, $commit) = @_;

    return message_errors($git, $commit, $commit->message);
}

# Install hooks
my $options = {config => \&_setup_config};

GITHOOKS_CHECK_AFFECTED_REFS(\&check_ref, $options);
GITHOOKS_CHECK_PATCHSET(\&check_patchset, $options);
GITHOOKS_CHECK_MESSAGE_FILE(\&check_message_file, $options);

1;

__END__