Login
RT #74647: False positive in TestingAndDebugging::ProhibitNoWarnings
authorTom Wyant <harryfmudd@comcast.net>
Fri, 3 Feb 2012 20:11:27 +0000 (20:11 +0000)
committerTom Wyant <harryfmudd@comcast.net>
Fri, 3 Feb 2012 20:11:27 +0000 (20:11 +0000)
(bad parsing)

The problem here was that the original code just stringified the
'no' statement, used a regular expression to extract all lowercase
strings, and then grep'ed out 'no', 'warnings', and 'qw'. Unfortunately,
'qw' is an actual warning category (believe it or not!), so the original
code saw

 no warnings 'qw';

as an unqualified 'no warnings'.

The patch recurses into the statement being analyzed, and finds all:
* PPI::Token::Word (because of 'foo => "bar"'),
* PPI::Token::Quote (because of "'foo'"), and
* PPI::Token::QuoteLike::Words (obviously).
The first two words (which are 'no' and 'warnings') are discarded, and
the rest are subjected to analysis. Note that, though the original code
rejects everything that is not entirely lower case alphabetic, the patch
accepts everything. My reason is that the difference was a "don't care",
becaue unknown warning categories don't compile, and thus are not
Perl::Critic's problem.

Changes
lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm
t/TestingAndDebugging/ProhibitNoWarnings.run

diff --git a/Changes b/Changes
index 0ad951b..5fc0a11 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,10 @@
+Next version, whenever
+
+    Policy Changes:
+    * TestingAndDebugging::ProhibitNoWarnings: Correct the parse of the
+      'no warnings' statement, so that 'no warnings "qw"' is recognized
+      as supressing just 'qw' warnings. RT #74647.
+
 [1.117] Released on 2011-12-21
 
     HAPPY HOLIDAYS!
index 9c82a2b..6c6a325 100644 (file)
@@ -14,6 +14,7 @@ use Readonly;
 
 use List::MoreUtils qw(all);
 
+use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
 use Perl::Critic::Utils qw{ :characters :severities :data_conversion };
 use base 'Perl::Critic::Policy';
 
@@ -74,20 +75,13 @@ sub violates {
     return if $elem->type()   ne 'no';
     return if $elem->pragma() ne 'warnings';
 
-    # Arguments to 'no warnings' are usually a list of literals or a
-    # qw() list.  Rather than trying to parse the various PPI elements,
-    # I just use a regex to split the statement into words.  This is
-    # kinda lame, but it does the trick for now.
-
-    # TODO consider: a possible alternate implementation:
-    #   my $re = join q{|}, keys %{$self->{allow}};
-    #   return if $re && $statement =~ m/\b(?:$re)\b/mx;
-    # May need to detaint for that to work...  Not sure.
-
-    my $statement = $elem->statement();
-    return if not $statement;
-    my @words = $statement =~ m/ ( [[:lower:]]+ ) /gxms;
-    @words = grep { $_ ne 'qw' && $_ ne 'no' && $_ ne 'warnings' } @words;
+    my @words = _extract_potential_categories( $elem );
+    @words >= 2
+        and 'no' eq $words[0]
+        and 'warnings' eq $words[1]
+        or throw_internal
+            q<'no warnings' word list did not begin with qw{ no warnings }>;
+    splice @words, 0, 2;
 
     return if $self->{_allow_with_category_restriction} and @words;
     return if @words && all { exists $self->{_allow}->{$_} } @words;
@@ -96,6 +90,45 @@ sub violates {
     return $self->violation( $DESC, $EXPL, $elem );
 }
 
+#-----------------------------------------------------------------------------
+
+# Traverse the element, accumulating and ultimately returning things
+# that might be warnings categories. These are:
+# * Words (because of the 'foo' in 'no warnings foo => "bar"');
+# * Quotes (because of 'no warnings "foo"');
+# * qw{} strings (obviously);
+# * Nodes (because of 'no warnings ( "foo", "bar" )').
+# We don't lop off the 'no' and 'warnings' because we recurse.
+# RT #74647.
+
+{
+
+    Readonly::Array my @HANDLER => (
+        [ 'PPI::Token::Word' => sub { return $_[0]->content() } ],
+        [ 'PPI::Token::QuoteLike::Words'  =>
+            sub { return $_[0]->literal() }, ],
+        [ 'PPI::Token::Quote' => sub { return $_[0]->string() } ],
+        [ 'PPI::Node' => sub { _extract_potential_categories( $_[0] ) } ],
+    );
+
+    sub _extract_potential_categories {
+        my ( $elem ) = @_;
+
+        my @words;
+        foreach my $child ( $elem->schildren() ) {
+            foreach my $hdlr ( @HANDLER ) {
+                $child->isa( $hdlr->[0] )
+                    or next;
+                push @words, $hdlr->[1]->( $child );
+                last;
+            }
+        }
+
+        return @words;
+    }
+
+}
+
 1;
 
 __END__
index f554214..03e20b6 100644 (file)
@@ -117,6 +117,16 @@ no warnings qw< uninitialized glob >;
 
 #-----------------------------------------------------------------------------
 
+## name allow_with_category_restriction, category qw. RT #74647,
+## failures 0
+## parms { allow_with_category_restriction => 1 }
+## cut
+
+no warnings 'qw';   # Yes, 'qw' is an actual warnings category.
+no warnings ( foo => "bar" );
+
+#-----------------------------------------------------------------------------
+
 ##############################################################################
 #      $URL$
 #     $Date$