File Coverage

blib/lib/Perl/Critic/Policy/Documentation/ProhibitDuplicateHeadings.pm
Criterion Covered Total %
statement 97 98 98.9
branch 30 34 88.2
condition 4 5 80.0
subroutine 15 15 100.0
pod 1 1 100.0
total 147 153 96.0


line stmt bran cond sub pod time code
1             # Copyright 2013, 2014, 2015, 2016, 2017, 2019, 2021 Kevin Ryde
2              
3             # This file is part of Perl-Critic-Pulp.
4              
5             # Perl-Critic-Pulp is free software; you can redistribute it and/or modify
6             # it under the terms of the GNU General Public License as published by the
7             # Free Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # Perl-Critic-Pulp is distributed in the hope that it will be useful, but
11             # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
12             # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13             # for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Perl-Critic-Pulp. If not, see <http://www.gnu.org/licenses/>.
17              
18              
19             # perlcritic -s ProhibitDuplicateHeadings ProhibitDuplicateHeadings.pm
20             #
21             # duplicate BUGS
22             # perlcritic -s ProhibitDuplicateHeadings /usr/share/perl5/Acme/Tie/Eleet.pm
23              
24             # duplicate toplevel CLASS METHODS
25             # perlcritic -s ProhibitDuplicateHeadings /usr/share/perl5/Games/Euchre/Trick.pm
26              
27             # duplicate =head2 serialise
28             # perlcritic -s ProhibitDuplicateHeadings /usr/share/perl5/SVG/Extension.pm
29              
30              
31             package Perl::Critic::Policy::Documentation::ProhibitDuplicateHeadings;
32 40     40   35897 use 5.006;
  40         166  
33 40     40   576 use strict;
  40         101  
  40         970  
34 40     40   278 use warnings;
  40         114  
  40         1405  
35 40     40   236 use base 'Perl::Critic::Policy';
  40         90  
  40         5278  
36 40     40   186802 use Perl::Critic::Utils;
  40         94  
  40         832  
37              
38             # uncomment this to run the ### lines
39             # use Smart::Comments;
40              
41             our $VERSION = 99;
42              
43 40         3193 use constant supported_parameters =>
44             ({ name => 'uniqueness',
45             description => 'The scope for headings names, meaning to what extent they must not be duplicates. Choices nested, all.',
46             behavior => 'string',
47             default_string => 'default',
48             parser => \&_parse_uniqueness,
49 40     40   39213 });
  40         107  
50 40     40   308 use constant default_severity => $Perl::Critic::Utils::SEVERITY_MEDIUM;
  40         94  
  40         2896  
51 40     40   281 use constant default_themes => qw(pulp bugs);
  40         93  
  40         2418  
52 40     40   276 use constant applies_to => 'PPI::Document';
  40         107  
  40         17300  
53              
54             sub violates {
55 45     45 1 133207 my ($self, $elem, $document) = @_;
56             ### ProhibitDuplicateHeadings ...
57             ### _uniqueness: $self->{'_uniqueness'}
58             # ### content: $elem->content
59              
60 45         988 my $parser = Perl::Critic::Pulp::PodParser::ProhibitDuplicateHeadings->new
61             (policy => $self);
62 45         270 $parser->parse_from_elem ($elem);
63              
64             ### violations return: [ $parser->violations ]
65 45         984 return $parser->violations;
66             }
67              
68             my %known_uniqueness = ('' => 1, # for trailing comma
69             all => 1,
70             ancestor => 1,
71             sibling => 1,
72             adjacent => 1,
73             default => 1,
74             );
75             my %uniqueness_expand = (default => [ 'ancestor', 'sibling', 'adjacent' ],
76             );
77             sub _parse_uniqueness {
78 52     52   6279936 my ($self, $parameter, $str) = @_;
79             ### _parse_uniqueness ...
80             ### $parameter
81             ### $str
82              
83 52 100       326 if (! defined $str) {
84 46         254 $str = $parameter->get_default_string;
85             ### default: $str
86             }
87              
88 52         367 my %uhash;
89 52         368 foreach my $key (split /,/, $str) {
90 53         249 $key =~ s/^\s+//;
91 53         266 $key =~ s/\s+$//;
92 53 50       375 if (! $known_uniqueness{$key}) {
93 0         0 $self->throw_parameter_value_exception
94             ($parameter->get_name,
95             $str,
96             undef, # source
97             'unrecognised uniqueness');
98             }
99 53 100       345 if (my $aref = $uniqueness_expand{$key}) {
100 47         219 foreach my $key (@$aref) {
101 141         575 $uhash{$key} = 1;
102             }
103             } else {
104 6         24 $uhash{$key} = 1;
105             }
106             }
107              
108             ### %uhash
109 52         600 $self->__set_parameter_value ($parameter, \%uhash);
110             }
111              
112             #------------------------------------------------------------------------------
113             package Perl::Critic::Pulp::PodParser::ProhibitDuplicateHeadings;
114 40     40   352 use strict;
  40         95  
  40         1258  
115 40     40   245 use warnings;
  40         92  
  40         1568  
116 40     40   263 use base 'Perl::Critic::Pulp::PodParser';
  40         115  
  40         25117  
117              
118             sub command {
119 140     140   13206 my $self = shift;
120 140         440 my ($command, $text, $linenum, $paraobj) = @_;
121             ### $command
122              
123 140 50       660 if ($command =~ /^head(\d*)$/) {
124 140   50     618 my $level = $1 || 0;
125 140         419 $text =~ s/^\s+//; # leading whitespace
126 140         611 $text =~ s/\s+$//; # trailing whitespace
127 140         383 $text =~ s/\s+/ /; # collapse whitespace to single space each
128             ### $text
129             ### $level
130              
131 140         464 my $uniqueness = $self->{'policy'}->{'_uniqueness'};
132 140         348 my $seen_linenum;
133             my $seen_type;
134              
135 140 100       435 if ($uniqueness->{'all'}) {
136 28 50       92 unless (defined $seen_linenum) {
137 28         83 $seen_linenum = $self->{'seen_all'}->{$text};
138 28         63 $seen_type = ' ';
139             }
140              
141 28         101 $self->{'seen_all'}->{$text} = $linenum;
142             }
143              
144 140 100       422 if ($uniqueness->{'adjacent'}) {
145 53 50       167 unless (defined $seen_linenum) {
146 53 100 100     313 if (defined $self->{'seen_adjacent'}
147             && $text eq $self->{'seen_adjacent'}) {
148 16         40 $seen_linenum = $self->{'seen_adjacent_linenum'};
149 16         48 $seen_type = ' adjacent ';
150             }
151             }
152 53         139 $self->{'seen_adjacent'} = $text;
153 53         158 $self->{'seen_adjacent_linenum'} = $linenum;
154             }
155              
156 140 100       453 if ($uniqueness->{'sibling'}) {
157             ### seen_sibling: $self->{'seen_sibling'}
158 59 100       178 unless (defined $seen_linenum) {
159 50         170 $seen_linenum = $self->{'seen_sibling'}->{$level}->{$text};
160 50         117 $seen_type = ' sibling ';
161             }
162              
163             # discard anything > $level
164 59         110 foreach my $l (keys %{$self->{'seen_sibling'}}) {
  59         214  
165 91 100       289 if ($l > $level) {
166 15         57 delete $self->{'seen_sibling'}->{$l};
167             }
168             }
169 59         215 $self->{'seen_sibling'}->{$level}->{$text} = $linenum;
170             }
171              
172 140 100       440 if ($uniqueness->{'ancestor'}) {
173 59         125 foreach my $l (sort {$a<=>$b} # biggest to smallest
  15         80  
174 59         284 keys %{$self->{'seen_ancestor'}}) {
175 55 100       193 if ($l < $level) {
176 21 100       94 if ($text eq $self->{'seen_ancestor'}->{$l}) {
177 5 100       23 unless (defined $seen_linenum) {
178 3         10 $seen_linenum = $self->{'seen_ancestor_linenum'}->{$l};
179 3         11 $seen_type = ' ancestor ';
180             }
181             }
182             } else {
183 34         86 delete $self->{'seen_ancestor'}->{$l};
184             }
185             }
186 59         191 $self->{'seen_ancestor'}->{$level} = $text;
187 59         173 $self->{'seen_ancestor_linenum'}->{$level} = $linenum;
188             }
189              
190             ### $seen_linenum
191             ### $seen_type
192 140 100       423 if (defined $seen_linenum) {
193 38         279 $self->violation_at_linenum
194             ("Duplicate$seen_type=head \"$text\", previously seen at line $seen_linenum",
195             $linenum);
196             ### violation at line: $linenum
197             }
198             }
199 140         2191 return '';
200             }
201              
202             1;
203             __END__
204              
205              
206             # within a
207             # nested tree scope. This is designed to be how A subheading can be repeated if under a
208             # different containing heading.
209             #
210             # Headings are thought of as a tree and a given heading must not duplicate a
211             # sibling or an ancestor.
212             #
213             # head1 head2 head3 no duplicate
214             # ----- ----- ----- ------------
215             #
216             # A--+--B A,J head1 siblings
217             # |
218             # +--C--+--D B,C,F,I,A head2 siblings and parent
219             # | |
220             # | +--E D,E,A,C head3 siblings and ancestors
221             # |
222             # +--F--+--G G,H,A,F head3 siblings and ancestors
223             # | |
224             # | +--H
225             # |
226             # +--I
227             #
228             # J--+--K K,L,M,J head2 siblings and parent
229             # |
230             # +--L
231             # |
232             # +--M
233             #
234             # "B" must be unique to its siblings C,F,I and its parent A.
235             #
236             # "D" must be unique to its sibling E and its ancestors A,C. But "D" doesn't
237             # have to be unique to F,G,H since F is not a direct ancestor and G,H are not
238             # siblings but cousins under the different branch F.
239             #
240             # This rule suits a construction like "A+C+D" to make a path to identify a
241             # point in the document (with some suitable separator between the parts).
242              
243              
244             =for stopwords Ryde
245              
246             =head1 NAME
247              
248             Perl::Critic::Policy::Documentation::ProhibitDuplicateHeadings - don't duplicate =head names
249              
250             =head1 DESCRIPTION
251              
252             This policy is part of the L<C<Perl::Critic::Pulp>|Perl::Critic::Pulp>
253             add-on. It asks you not to duplicate heading names in C<=head> POD
254             commands.
255              
256             =head1 SOMETHING
257              
258             =head1 SOMETHING # bad, duplicate
259              
260             Duplication is usually a mistake, perhaps too much cut-and-paste, or a
261             leftover from a template, or perhaps text in two places which ought to be
262             together. On that basis this policy is medium severity and under the "bugs"
263             theme (see L<Perl::Critic/POLICY THEMES>).
264              
265             =head2 Default Uniqueness
266              
267             The policy default is to demand that a given heading is unique to its
268             ancestors, siblings, and to the immediately adjacent heading irrespective of
269             level. This is designed to be how human readers perceive the scope of
270             headings and subheadings, plus adjacency in case a mixture of heading levels
271             would let a duplicate otherwise go undetected. For example
272              
273             =head1 Top
274              
275             =head2 Subhead
276              
277             =head3 Top # bad, duplicates its ancestor head1
278              
279             Or siblings
280              
281             =head1 Top
282              
283             =head2 Down
284              
285             =head2 Another
286              
287             =head2 Down # bad, duplicates sibling head2
288              
289             Or adjacent
290              
291             =head2 Blah
292              
293             =head1 Blah # bad, duplicates adjacent
294              
295             A subheading can be repeated if it's under a different higher heading. For
296             example the following two "Details" are cousins, so allowed.
297              
298             =head1 One
299              
300             =head2 Details
301              
302             =head1 Two
303              
304             =head2 Details # ok
305              
306             =head2 All Unique
307              
308             Option C<uniqueness=all> (see L</CONFIGURATION> below) applies a stricter
309             rule so that all C<=head> names must be unique throughout the document,
310             irrespective of levels and structure.
311              
312             =head3 Foo
313              
314             =head1 Bar
315              
316             =head3 Foo # bad
317              
318             One use for this is to ensure all headings can be reached by an
319             C<LE<lt>E<gt>> link. An C<LE<lt>E<gt>> only has the heading name, no level
320             or path, so if there's any duplication among the names then only the first
321             of each duplicate will be reachable. (The POD browsers usually go to the
322             first among duplicates.)
323              
324             This rule is often too strict. It can be good to have similar subheadings
325             like "Details" as shown above, with no need to make such sub-parts reachable
326             by a link.
327              
328             =head2 Disabling
329              
330             If you don't care at all about this you can disable
331             C<ProhibitDuplicateHeadings> from your F<.perlcriticrc> in the usual way (see
332             L<Perl::Critic/CONFIGURATION>),
333              
334             [-Documentation::ProhibitDuplicateHeadings]
335              
336             =head1 CONFIGURATION
337              
338             =over 4
339              
340             =item C<uniqueness> (string, default "default")
341              
342             The uniqueness to be enforced on each heading. The value is a
343             comma-separated list of
344              
345             default currently "ancestor,sibling,adjacent"
346             ancestor don't duplicate parent, grandparent, etc
347             sibling same level and parent
348             adjacent immediately preceding, irrespective of level
349             all all headings
350              
351             The default is "default" and the intention is to have default mean a
352             sensible set of restrictions, though precisely what it might be could
353             change.
354              
355             For example in your F<.perlcriticrc> file
356              
357             [Documentation::ProhibitDuplicateHeadings]
358             uniqueness=ancestor,adjacent
359              
360             =back
361              
362             =head1 SEE ALSO
363              
364             L<Perl::Critic::Pulp>, L<Perl::Critic>
365              
366             L<Perl::Critic::Policy::Documentation::ProhibitDuplicateSeeAlso>,
367             L<Perl::Critic::Policy::Documentation::RequirePodSections>
368              
369             =head1 HOME PAGE
370              
371             http://user42.tuxfamily.org/perl-critic-pulp/index.html
372              
373             =head1 COPYRIGHT
374              
375             Copyright 2013, 2014, 2015, 2016, 2017, 2019, 2021 Kevin Ryde
376              
377             Perl-Critic-Pulp is free software; you can redistribute it and/or modify it
378             under the terms of the GNU General Public License as published by the Free
379             Software Foundation; either version 3, or (at your option) any later
380             version.
381              
382             Perl-Critic-Pulp is distributed in the hope that it will be useful, but
383             WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
384             or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
385             more details.
386              
387             You should have received a copy of the GNU General Public License along with
388             Perl-Critic-Pulp. If not, see <http://www.gnu.org/licenses/>.
389              
390             =cut