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


line stmt bran cond sub pod time code
1 1     1   3977 use warnings;
  1         13  
  1         71  
2              
3             package Git::Hooks::CheckLog;
4             # ABSTRACT: Git::Hooks plugin to enforce commit log policies
5             $Git::Hooks::CheckLog::VERSION = '3.5.0';
6 1     1   27 use v5.16.0;
  1         4  
7 1     1   11 use utf8;
  1         2  
  1         6  
8 1     1   41 use Log::Any '$log';
  1         2  
  1         20  
9 1     1   856 use Git::Hooks;
  1         3  
  1         197  
10 1     1   359 use Git::Message;
  1         4  
  1         39  
11 1     1   526 use List::MoreUtils qw/uniq/;
  1         13001  
  1         5  
12              
13             my $CFG = __PACKAGE__ =~ s/.*::/githooks./r;
14              
15             #############
16             # Grok hook configuration, check it and set defaults.
17              
18             sub _setup_config {
19 0     0   0 my ($git) = @_;
20              
21 0         0 my $config = $git->get_config();
22              
23 0   0     0 $config->{lc $CFG} //= {};
24              
25 0         0 my $default = $config->{lc $CFG};
26 0   0     0 $default->{'title-required'} //= ['true'];
27 0   0     0 $default->{'title-max-width'} //= [50];
28 0   0     0 $default->{'title-period'} //= ['deny'];
29 0   0     0 $default->{'body-max-width'} //= [72];
30              
31 0         0 return;
32             }
33              
34             ##########
35              
36             # Return a Text::SpellChecker object or undef.
37              
38             sub _spell_checker {
39 1     1   12983 my ($git, $msg) = @_;
40              
41 1         7 my %extra_options;
42              
43 1 50       33 if (my $lang = $git->get_config($CFG => 'spelling-lang')) {
44 0         0 $extra_options{lang} = $lang;
45             }
46              
47 1 50       6 unless (state $tried_to_check) {
48 1 50       3 unless (eval { require Text::SpellChecker; }) {
  1         946  
49 1         6943 $git->fault(<<'EOS', {option => 'spelling', details => $@});
50             I could not load the Text::SpellChecker Perl module.
51              
52             I need it to spell check your commit's messages as requested by this
53             configuration option.
54              
55             Please, install the module or disable the option to proceed.
56             EOS
57 1         91 return;
58             }
59              
60             # Text::SpellChecker uses either Text::Hunspell or
61             # Text::Aspell to perform the checks. But it doesn't try to
62             # load those modules until we invoke its next_word method. So,
63             # in order to detect errors in those modules we first create a
64             # bogus Text::SpellChecker object and force it to spell a word
65             # to see if it can go so far.
66              
67 0           my $checker = Text::SpellChecker->new(text => 'a', %extra_options);
68              
69 0 0 0       if (! defined eval { $checker->next_word(); } && $@) {
  0            
70 0           $git->fault(<<'EOS', {option => 'spelling', details => $@});
71             There was an error while I tried to spell check your commits using the
72             Text::SpellChecker module. If you cannot fix it consider disabling this
73             your configuration option.
74             EOS
75 0           return;
76             }
77              
78 0           $tried_to_check = 1;
79             }
80              
81 0           return Text::SpellChecker->new(text => $msg, %extra_options);
82             }
83              
84             sub spelling_errors {
85 0     0 0   my ($git, $id, $msg) = @_;
86              
87 0 0         return 0 unless $msg;
88              
89 0 0         return 0 unless $git->get_config_boolean($CFG => 'spelling');
90              
91             # Check all words comprised of at least three Unicode letters
92 1 0   1   1518 my $checker = _spell_checker($git, join("\n", uniq($msg =~ /\b(\p{Cased_Letter}{3,})\b/gi)))
  1         2  
  1         21  
  0            
93             or return 1;
94              
95 0           my $errors = 0;
96              
97 0           foreach my $badword ($checker->next_word()) {
98 0           my @suggestions = $checker->suggestions($badword);
99 0           my %info = (option => 'spelling');
100 0 0         $info{details} = join("\n ", 'SUGGESTIONS:', @suggestions)
101             if defined $suggestions[0];
102 0           $git->fault("The commit $id log message has a misspelled word: '$badword'", \%info);
103 0           ++$errors;
104             }
105              
106 0           return $errors;
107             }
108              
109             ##########
110             # Perform a single pattern check and return the number of errors.
111              
112             sub _pattern_error {
113 0     0     my ($git, $text, $match, $what, $id) = @_;
114              
115 0 0         if ($match =~ s/^!\s*//) {
116 0 0 0       $text !~ /$match/m
117             or $git->fault("The commit log $what SHOULD NOT match '\Q$match\E'",
118             {commit => $id, option => 'match'})
119             and return 1;
120             }
121             else {
122 0 0 0       $text =~ /$match/m
123             or $git->fault("The commit log $what SHOULD match '\Q$match\E'",
124             {commit => $id, option => 'match'})
125             and return 1;
126             }
127              
128 0           return 0;
129             }
130              
131             sub pattern_errors {
132 0     0 0   my ($git, $id, $msg) = @_;
133              
134 0           my $errors = 0;
135              
136 0           foreach my $match ($git->get_config($CFG => 'match')) {
137 0           $errors += _pattern_error($git, $msg, $match, 'message', $id);
138             }
139              
140 0           return $errors;
141             }
142              
143             sub revert_errors {
144 0     0 0   my ($git, $id, $msg) = @_;
145              
146 0 0         if ($git->get_config_boolean($CFG => 'deny-merge-revert')) {
147 0 0         if ($msg =~ /This reverts commit ([0-9a-f]{40})/s) {
148             # Get the reverted commit in an eval because it may be unreachable
149             # now. In this case we simply don't care anymore.
150 0 0         if (my $reverted_commit = eval {$git->get_commit($1)}) {
  0            
151 0 0         if ($reverted_commit->parent() > 1) {
152 0           $git->fault(<<'EOS', {commit => $id, option => 'deny-merge-revert'});
153             This commit reverts a merge commit, which is not allowed
154             by your configuration option.
155             EOS
156 0           return 1;
157             }
158             }
159             }
160             }
161              
162 0           return 0;
163             }
164              
165             sub title_errors {
166 0     0 0   my ($git, $id, $title) = @_;
167              
168 0 0 0       unless (defined $title and length $title) {
169 0 0         if ($git->get_config_boolean($CFG => 'title-required')) {
170 0           $git->fault(<<'EOS', {commit => $id, option => 'title-required'});
171             This commit log message needs a title line.
172             This is required by your configuration option.
173             Please, amend your commit to add one.
174             EOS
175 0           return 1;
176             } else {
177 0           return 0;
178             }
179             }
180              
181 0 0 0       ($title =~ tr/\n/\n/) == 1
182             or $git->fault(<<'EOS', {commit => $id})
183             This commit log message title must have just one line.
184             Please amend your commit and edit its log message so that its first line
185             is separated from the rest by an empty line.
186             EOS
187             and return 1;
188              
189 0           my $errors = 0;
190              
191 0 0         if (my $max_width = $git->get_config_integer($CFG => 'title-max-width')) {
192 0           my $tlen = length($title) - 1; # discount the newline
193 0 0 0       $tlen <= $max_width
194             or $git->fault(<<"EOS", {commit => $id, option => 'title-max-width'})
195             This commit log message title is too long.
196             It is $tlen characters wide but should be at most $max_width, a limit set by
197             your configuration option.
198             Please, amend your commit to make its title shorter.
199             EOS
200             and ++$errors;
201             }
202              
203 0 0         if (my $period = $git->get_config($CFG => 'title-period')) {
204 0 0         if ($period eq 'deny') {
    0          
    0          
205 0 0 0       $title !~ /\.$/
206             or $git->fault(<<'EOS', {commit => $id, option => 'title-period'})
207             This commit log message title SHOULD NOT end in a period.
208             This is required by your configuration option.
209             Please, amend your commit to remove the period.
210             EOS
211             and ++$errors;
212             } elsif ($period eq 'require') {
213 0 0 0       $title =~ /\.$/
214             or $git->fault(<<'EOS', {commit => $id, option => 'title-period'})
215             This commit log message title SHOULD end in a period.
216             This is required by your configuration option.
217             Please, amend your commit to add the period.
218             EOS
219             and ++$errors;
220             } elsif ($period ne 'allow') {
221 0 0         $git->fault(<<"EOS", {commit => $id, option => 'title-period'})
222             Configuration error: invalid value '$period' for the configuration option.
223             The valid values are 'deny', 'allow', and 'require'.
224             EOS
225             and ++$errors;
226             }
227             }
228              
229 0           foreach my $match ($git->get_config($CFG => 'title-match')) {
230 0           $errors += _pattern_error($git, $title, $match, 'title', $id);
231             }
232              
233 0           return $errors;
234             }
235              
236             sub body_errors {
237 0     0 0   my ($git, $id, $body) = @_;
238              
239 0 0 0       return 0 unless defined $body && length $body;
240              
241 0 0         if (my $max_width = $git->get_config_integer($CFG => 'body-max-width')) {
242 0 0         if (my @biggies = grep {/^\S/} grep {length > $max_width} split(/\n/, $body)) {
  0            
  0            
243 0           $git->fault(<<"EOS", {commit => $id, option => 'body-max-width', details => join("\n", @biggies)});
244             This commit log body has lines that are too long.
245             The configuration option limits body lines to $max_width characters.
246             But the following lines exceed it.
247             Please, amend your commit to make its lines shorter.
248             EOS
249 0           return 1;
250             }
251             }
252              
253 0           return 0;
254             }
255              
256             sub footer_errors {
257 0     0 0   my ($git, $id, $cmsg) = @_;
258              
259 0           my $errors = 0;
260              
261 0           my @signed_off_by = $cmsg->get_footer_values('signed-off-by');
262              
263 0 0         if (@signed_off_by) {
    0          
264             # Check for duplicate Signed-off-by footers
265 0           my (%signed_off_by, @duplicates);
266 0           foreach my $person (@signed_off_by) {
267 0           $signed_off_by{$person} += 1;
268 0 0         if ($signed_off_by{$person} == 2) {
269 0           push @duplicates, $person;
270             }
271             }
272 0 0         if (@duplicates) {
273 0           $git->fault(<<'EOS', {commit => $id, details => join("\n", sort @duplicates)});
274             This commit have duplicate Signed-off-by footers.
275             Please, amend it to remove the duplicates:
276             EOS
277 0           ++$errors;
278             }
279             } elsif ($git->get_config_boolean($CFG => 'signed-off-by')) {
280 0           $git->fault(<<'EOS', {commit => $id, option => 'signed-off-by'});
281             This commit must have a Signed-off-by footer.
282             This is required by your configuration option.
283             Please, amend your commit to add it.
284             EOS
285 0           ++$errors;
286             }
287              
288 0           return $errors;
289             }
290              
291             sub message_errors {
292 0     0 0   my ($git, $commit, $msg) = @_;
293              
294             # assert(defined $msg)
295              
296 0 0         my $id = defined $commit ? $commit->commit : '';
297              
298 0           my $cmsg = Git::Message->new($msg);
299              
300             return
301 0           spelling_errors($git, $id, $msg) +
302             pattern_errors($git, $id, $msg) +
303             revert_errors($git, $id, $msg) +
304             title_errors($git, $id, $cmsg->title) +
305             body_errors($git, $id, $cmsg->body) +
306             footer_errors($git, $id, $cmsg);
307             }
308              
309             sub check_message_file {
310 0     0 0   my ($git, $msg) = @_;
311              
312 0           return message_errors($git, undef, $msg);
313             }
314              
315             sub check_ref {
316 0     0 0   my ($git, $ref) = @_;
317              
318 0           my $errors = 0;
319              
320 0           foreach my $commit ($git->get_affected_ref_commits($ref)) {
321 0           $errors += message_errors($git, $commit, $commit->message);
322             }
323              
324 0           return $errors;
325             }
326              
327             sub check_patchset {
328 0     0 0   my ($git, $branch, $commit) = @_;
329              
330 0           return message_errors($git, $commit, $commit->message);
331             }
332              
333             # Install hooks
334             my $options = {config => \&_setup_config};
335              
336             GITHOOKS_CHECK_AFFECTED_REFS(\&check_ref, $options);
337             GITHOOKS_CHECK_PATCHSET(\&check_patchset, $options);
338             GITHOOKS_CHECK_MESSAGE_FILE(\&check_message_file, $options);
339              
340             1;
341              
342             __END__