File Coverage

blib/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm
Criterion Covered Total %
statement 52 52 100.0
branch 12 14 85.7
condition 8 12 66.6
subroutine 16 16 100.0
pod 4 5 80.0
total 92 99 92.9


line stmt bran cond sub pod time code
1             package Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings;
2              
3 40     40   27003 use 5.010001;
  40         183  
4 40     40   258 use strict;
  40         132  
  40         856  
5 40     40   246 use warnings;
  40         120  
  40         936  
6 40     40   219 use Readonly;
  40         123  
  40         2196  
7              
8 40     40   294 use List::SomeUtils qw(all);
  40         115  
  40         1995  
9              
10 40     40   310 use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
  40         107  
  40         2563  
11 40     40   268 use Perl::Critic::Utils qw{ :characters :severities :data_conversion };
  40         134  
  40         2285  
12 40     40   13262 use parent 'Perl::Critic::Policy';
  40         120  
  40         239  
13              
14             our $VERSION = '1.148';
15              
16             #-----------------------------------------------------------------------------
17              
18             Readonly::Scalar my $DESC => q{Warnings disabled};
19             Readonly::Scalar my $EXPL => [ 431 ];
20              
21             #-----------------------------------------------------------------------------
22              
23             sub supported_parameters {
24             return (
25             {
26 103     103 0 2585 name => 'allow',
27             description => 'Permitted warning categories.',
28             default_string => $EMPTY,
29             parser => \&_parse_allow,
30             },
31             {
32             name => 'allow_with_category_restriction',
33             description =>
34             'Allow "no warnings" if it restricts the kinds of warnings that are turned off.',
35             default_string => '0',
36             behavior => 'boolean',
37             },
38             );
39             }
40              
41 80     80 1 395 sub default_severity { return $SEVERITY_HIGH }
42 92     92 1 410 sub default_themes { return qw( core bugs pbp certrec ) }
43 44     44 1 186 sub applies_to { return 'PPI::Statement::Include' }
44              
45             #-----------------------------------------------------------------------------
46              
47             sub _parse_allow {
48 101     101   544 my ($self, $parameter, $config_string) = @_;
49              
50 101         412 $self->{_allow} = {};
51              
52 101 100       467 if( defined $config_string ) {
53 6         28 my $allowed = lc $config_string; #String of words
54 6         52 my %allowed = hashify( $allowed =~ m/ (experimental::\w+|\w+) /gxms );
55              
56 6         28 $self->{_allow} = \%allowed;
57             }
58              
59 101         315 return;
60             }
61              
62             #-----------------------------------------------------------------------------
63              
64             sub violates {
65              
66 74     74 1 229 my ( $self, $elem, undef ) = @_;
67              
68 74 100       251 return if $elem->type() ne 'no';
69 13 50       418 return if $elem->pragma() ne 'warnings';
70              
71 13         525 my @words = _extract_potential_categories( $elem );
72 13 50 33     138 @words >= 2
      33        
73             and 'no' eq $words[0]
74             and 'warnings' eq $words[1]
75             or throw_internal
76             q<'no warnings' word list did not begin with qw{ no warnings }>;
77 13         39 splice @words, 0, 2;
78              
79 13 100 100     156 return if $self->{_allow_with_category_restriction} and @words;
80 8 100 100 11   66 return if @words && all { exists $self->{_allow}->{$_} } @words;
  11         56  
81              
82             #If we get here, then it must be a violation
83 6         48 return $self->violation( $DESC, $EXPL, $elem );
84             }
85              
86             #-----------------------------------------------------------------------------
87              
88             # Traverse the element, accumulating and ultimately returning things
89             # that might be warnings categories. These are:
90             # * Words (because of the 'foo' in 'no warnings foo => "bar"');
91             # * Quotes (because of 'no warnings "foo"');
92             # * qw{} strings (obviously);
93             # * Nodes (because of 'no warnings ( "foo", "bar" )').
94             # We don't lop off the 'no' and 'warnings' because we recurse.
95             # RT #74647.
96              
97             {
98              
99             Readonly::Array my @HANDLER => (
100             [ 'PPI::Token::Word' => sub { return $_[0]->content() } ],
101             [ 'PPI::Token::QuoteLike::Words' =>
102             sub { return $_[0]->literal() }, ],
103             [ 'PPI::Token::Quote' => sub { return $_[0]->string() } ],
104             [ 'PPI::Node' => sub { _extract_potential_categories( $_[0] ) } ],
105             );
106              
107             sub _extract_potential_categories {
108 15     15   50 my ( $elem ) = @_;
109              
110 15         36 my @words;
111 15         63 foreach my $child ( $elem->schildren() ) {
112 66         509 foreach my $hdlr ( @HANDLER ) {
113 162 100       2183 $child->isa( $hdlr->[0] )
114             or next;
115 46         606 push @words, $hdlr->[1]->( $child );
116 46         535 last;
117             }
118             }
119              
120 15         232 return @words;
121             }
122              
123             }
124              
125             1;
126              
127             __END__
128              
129             #-----------------------------------------------------------------------------
130              
131             =pod
132              
133             =for stopwords perllexwarn
134              
135             =head1 NAME
136              
137             Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings - Prohibit various flavors of C<no warnings>.
138              
139              
140             =head1 AFFILIATION
141              
142             This Policy is part of the core L<Perl::Critic|Perl::Critic>
143             distribution.
144              
145              
146             =head1 DESCRIPTION
147              
148             There are good reasons for disabling certain kinds of warnings. But
149             if you were wise enough to C<use warnings> in the first place, then it
150             doesn't make sense to disable them completely. By default, any
151             C<no warnings> statement will violate this policy. However, you can
152             configure this Policy to allow certain types of warnings to be
153             disabled (See L<"CONFIGURATION">). A bare C<no warnings>
154             statement will always raise a violation.
155              
156              
157             =head1 CONFIGURATION
158              
159             The permitted warning types can be configured via the C<allow> option.
160             The value is a list of whitespace-delimited warning types that you
161             want to be able to disable. See L<perllexwarn|perllexwarn> for a list
162             of possible warning types. An example of this customization:
163              
164             [TestingAndDebugging::ProhibitNoWarnings]
165             allow = uninitialized once
166              
167             If a true value is specified for the
168             C<allow_with_category_restriction> option, then any C<no warnings>
169             that restricts the set of warnings that are turned off will pass.
170              
171             [TestingAndDebugging::ProhibitNoWarnings]
172             allow_with_category_restriction = 1
173              
174             =head1 SEE ALSO
175              
176             L<Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings|Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings>
177              
178              
179             =head1 AUTHOR
180              
181             Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>
182              
183              
184             =head1 COPYRIGHT
185              
186             Copyright (c) 2005-2021 Imaginative Software Systems. All rights reserved.
187              
188             This program is free software; you can redistribute it and/or modify it under
189             the same terms as Perl itself. The full text of this license can be found in
190             the LICENSE file included with this module
191              
192             =cut
193              
194             ##############################################################################
195             # Local Variables:
196             # mode: cperl
197             # cperl-indent-level: 4
198             # fill-column: 78
199             # indent-tabs-mode: nil
200             # c-indentation-style: bsd
201             # End:
202             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :