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