Login
Pulled all the 'no critic' handling code out of Critic.pm
authorJeffrey Ryan Thalhammer <jeff@imaginative-software.com>
Sun, 26 Oct 2008 09:26:16 +0000 (09:26 +0000)
committerJeffrey Ryan Thalhammer <jeff@imaginative-software.com>
Sun, 26 Oct 2008 09:26:16 +0000 (09:26 +0000)
and put it into Document.pm.  The internals are still kinda
ugly, but the interface is much nicer (I think).

TODO.pod
lib/Perl/Critic.pm
lib/Perl/Critic/Document.pm

index fb66b9a..995017d 100644 (file)
--- a/TODO.pod
+++ b/TODO.pod
@@ -443,24 +443,6 @@ See https://rt.cpan.org/Ticket/Display.html?id=38074.
 
 =item * Create constants for the PPI location array elements.
 
-
-=item * MOVE THE LINE-DISABLING INTO P::C::Document
-
-All the code that deals with finding all the '##no critic' comments and noting
-which policies are disabled at each line seems like it would be better placed
-in Perl::Critic::Document.  P::C::Document could then provide methods to
-indicate if a policy is disabled at a particular line.  So the basic algorithm
-in Perl::Critic might look something like this:
-
-  foreach $element (@PPI_ELEMENTS) {
-     foreach $policy (@POLICIES) {
-        $line = $element->location->[0];
-        next if $doc->policy_is_disabled_at_line( $policy, $line );
-        push @violations, $policy->violates( $elem, $doc );
-     }
-  }
-
-
 =item * Some means of detecting "runnaway" C<##no critic>
 
 Elliot was talking to a couple of users at ETech and one of their major
index 36e9daf..971e06c 100644 (file)
@@ -79,7 +79,7 @@ sub statistics {
 
 #-----------------------------------------------------------------------------
 
-sub critique {  ##no critic (ArgUnpacking)
+sub critique {  ## no critic (ArgUnpacking)
 
     #-------------------------------------------------------------------
     # This subroutine can be called as an object method or as a static
@@ -148,20 +148,15 @@ sub _create_perl_critic_document {
 sub _gather_violations {
     my ($self, $doc) = @_;
 
-    # Disable the magic shebang fix
-    my %is_line_disabled = _unfix_shebang($doc);
-
-    # Filter exempt code, if desired
+    # Disable exempt code lines, if desired
     if ( not $self->config->force() ) {
         my @site_policies = $self->config->site_policy_names();
-        %is_line_disabled = ( %is_line_disabled,
-                              _filter_code($doc, @site_policies) );
+        $doc->mark_disabled_lines(@site_policies);
     }
 
     # Evaluate each policy
     my @policies = $self->config->policies();
-    my @violations =
-        map { _critique( $_, $doc, \%is_line_disabled) } @policies;
+    my @violations = map { _critique($_, $doc) } @policies;
 
     # Accumulate statistics
     $self->statistics->accumulate( $doc, \@violations );
@@ -187,7 +182,7 @@ sub _is_ppi_doc {
 #-----------------------------------------------------------------------------
 
 sub _critique {
-    my ($policy, $doc, $is_line_disabled) = @_;
+    my ($policy, $doc) = @_;
 
     return if not $policy->prepare_to_scan_document($doc);
 
@@ -212,12 +207,8 @@ sub _critique {
           VIOLATION:
             for my $violation ( $policy->violates( $element, $doc ) ) {
                 my $line = $violation->location()->[0];
-                if (exists $is_line_disabled->{$line}) {
-                    next VIOLATION if $is_line_disabled->{$line}->{$policy_name}
-                        && not exists $policies_that_cannot_be_disabled{$policy_name}; 
-                    next VIOLATION if $is_line_disabled->{$line}->{ALL}
-                        && not exists $policies_that_cannot_be_disabled{$policy_name};
-                }
+                next VIOLATION if $doc->line_is_disabled($line, $policy_name)
+                    and not exists $policies_that_cannot_be_disabled{$policy_name};
 
                 push @violations, $violation;
                 if (
@@ -235,170 +226,10 @@ sub _critique {
 
 #-----------------------------------------------------------------------------
 
-sub _filter_code {
-
-    my ($doc, @site_policies)= @_;
-
-    my $nodes_ref  = $doc->find('PPI::Token::Comment') || return;
-    my %disabled_lines;
-
-    _filter_shebang_line($nodes_ref, \%disabled_lines, \@site_policies);
-    _filter_other_lines($nodes_ref, \%disabled_lines, \@site_policies);
-    return %disabled_lines;
-}
-
-sub _filter_shebang_line {
-    my ($nodes_ref, $disabled_lines, $site_policies) = @_;
-
-    my $shebang_no_critic  = qr{\A [#]! .*? [#][#] \s* no  \s+ critic}xms;
-
-    # Special case for the very beginning of the file: allow "##no critic" after the shebang
-    if (0 < @{$nodes_ref}) {
-        my $loc = $nodes_ref->[0]->location;
-        if (1 == $loc->[0] && 1 == $loc->[1] && $nodes_ref->[0] =~ $shebang_no_critic) {
-            my $pragma = shift @{$nodes_ref};
-            for my $policy (_parse_nocritic_import($pragma, $site_policies)) {
-                $disabled_lines->{ 1 }->{$policy} = 1;
-            }
-        }
-    }
-    return;
-}
-
-sub _filter_other_lines {
-    my ($nodes_ref, $disabled_lines, $site_policies) = @_;
-
-    my $no_critic  = qr{\A \s* [#][#] \s* no  \s+ critic}xms;
-    my $use_critic = qr{\A \s* [#][#] \s* use \s+ critic}xms;
-
-  PRAGMA:
-    for my $pragma ( grep { $_ =~ $no_critic } @{$nodes_ref} ) {
-
-        # Parse out the list of Policy names after the
-        # 'no critic' pragma.  I'm thinking of this just
-        # like a an C<import> argument for real pragmas.
-        my @no_policies = _parse_nocritic_import($pragma, $site_policies);
-
-        # Grab surrounding nodes to determine the context.
-        # This determines whether the pragma applies to
-        # the current line or the block that follows.
-        my $parent = $pragma->parent();
-        my $grandparent = $parent ? $parent->parent() : undef;
-        my $sib = $pragma->sprevious_sibling();
-
-
-        # Handle single-line usage on simple statements
-        if ( $sib && $sib->location->[0] == $pragma->location->[0] ) {
-            my $line = $pragma->location->[0];
-            for my $policy ( @no_policies ) {
-                $disabled_lines->{ $line }->{$policy} = 1;
-            }
-            next PRAGMA;
-        }
-
-
-        # Handle single-line usage on compound statements
-        if ( ref $parent eq 'PPI::Structure::Block' ) {
-            if ( ref $grandparent eq 'PPI::Statement::Compound'
-                 || ref $grandparent eq 'PPI::Statement::Sub' ) {
-                if ( $parent->location->[0] == $pragma->location->[0] ) {
-                    my $line = $grandparent->location->[0];
-                    for my $policy ( @no_policies ) {
-                        $disabled_lines->{ $line }->{$policy} = 1;
-                    }
-                    next PRAGMA;
-                }
-            }
-        }
-
-
-        # Handle multi-line usage.  This is either a "no critic" ..
-        # "use critic" region or a block where "no critic" persists
-        # until the end of the scope.  The start is the always the "no
-        # critic" which we already found.  So now we have to search
-        # for the end.
-
-        my $start = $pragma;
-        my $end   = $pragma;
-
-      SIB:
-        while ( my $esib = $end->next_sibling() ) {
-            $end = $esib; # keep track of last sibling encountered in this scope
-            last SIB
-                if $esib->isa('PPI::Token::Comment') && $esib =~ $use_critic;
-        }
-
-        # We either found an end or hit the end of the scope.
-        # Flag all intervening lines
-        for my $line ( $start->location->[0] .. $end->location->[0] ) {
-            for my $policy ( @no_policies ) {
-                $disabled_lines->{ $line }->{$policy} = 1;
-            }
-        }
-    }
-
-    return;
-}
-
-#-----------------------------------------------------------------------------
-
-sub _parse_nocritic_import {
-
-    my ($pragma, $site_policies) = @_;
-
-    my $module    = qr{ [\w:]+ }xms;
-    my $delim     = qr{ \s* [,\s] \s* }xms;
-    my $qw        = qr{ (?: qw )? }xms;
-    my $qualifier = qr{ $qw [(]? \s* ( $module (?: $delim $module)* ) \s* [)]? }xms;
-    my $no_critic = qr{ \#\# \s* no \s+ critic \s* $qualifier }xms;  ##no critic(EscapedMetacharacters)
-
-    if ( my ($module_list) = $pragma =~ $no_critic ) {
-        my @modules = split $delim, $module_list;
-
-        # Compose the specified modules into a regex alternation.  Wrap each
-        # in a no-capturing group to permit "|" in the modules specification
-        # (backward compatibility)
-        my $re = join q{|}, map {"(?:$_)"} @modules;
-        return grep {m/$re/ixms} @{$site_policies};
-    }
-
-    # Default to disabling ALL policies.
-    return qw(ALL);
-}
-
-#-----------------------------------------------------------------------------
-sub _unfix_shebang {
-
-    # When you install a script using ExtUtils::MakeMaker or Module::Build, it
-    # inserts some magical code into the top of the file (just after the
-    # shebang).  This code allows people to call your script using a shell,
-    # like `sh my_script`.  Unfortunately, this code causes several Policy
-    # violations, so we just disable it as if a "## no critic" comment had
-    # been attached.
-
-    my $doc         = shift;
-    my $first_stmnt = $doc->schild(0) || return;
-
-    # Different versions of MakeMaker and Build use slightly different shebang
-    # fixing strings.  This matches most of the ones I've found in my own Perl
-    # distribution, but it may not be bullet-proof.
-
-    my $fixin_rx = qr{^eval 'exec .* \$0 \${1\+"\$@"}'\s*[\r\n]\s*if.+;}ms; ## no critic (RequireExtendedFormatting)
-    if ( $first_stmnt =~ $fixin_rx ) {
-        my $line = $first_stmnt->location()->[0];
-        return ( $line => {ALL => 1}, $line + 1 => {ALL => 1} );
-    }
-
-    #No magic shebang was found!
-    return;
-}
-
-#-----------------------------------------------------------------------------
-
 sub _policies_that_cannot_be_disabled {
     # This is a special list of policies that cannot
     # be disabled by the "no critic" pseudo-pragma.
-    
+
     return qw(
         Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic
     );
index 4deab56..81ff126 100644 (file)
@@ -23,7 +23,7 @@ our $VERSION = '1.093_01';
 #-----------------------------------------------------------------------------
 
 our $AUTOLOAD;
-sub AUTOLOAD {  ## no critic(ProhibitAutoloading,ArgUnpacking)
+sub AUTOLOAD {  ## no critic (ProhibitAutoloading,ArgUnpacking)
     my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms;
     return if $function_name eq 'DESTROY';
     my $self = shift;
@@ -34,7 +34,10 @@ sub AUTOLOAD {  ## no critic(ProhibitAutoloading,ArgUnpacking)
 
 sub new {
     my ($class, $doc) = @_;
-    return bless { _doc => $doc }, $class;
+    my $self = bless {}, $class;
+    $self->{_disabled_lines} = _unfix_shebang($doc);
+    $self->{_doc} = $doc;
+    return $self;
 }
 
 #-----------------------------------------------------------------------------
@@ -155,6 +158,32 @@ sub highest_explicit_perl_version {
     return;
 }
 
+#-----------------------------------------------------------------------------
+
+sub mark_disabled_lines {
+    my ($self, @site_policies) = @_;
+    my %disabled_lines = _find_disabled_lines($self->{_doc}, @site_policies);
+
+    # Ick.  Need to merge the disabled lines hash with the shebang lines
+    # that we alread disabled during the _unfix_shebang() process.  Need
+    # to find a better way to express this.
+
+    $self->{_disabled_lines} = { %{$self->{_disabled_lines}}, %disabled_lines };
+    return $self;
+}
+
+#-----------------------------------------------------------------------------
+
+sub line_is_disabled {
+    my ($self, $line, $policy_name) = @_;
+    return 0 if not exists $self->{_disabled_lines}->{$line};
+    return 1 if $self->{_disabled_lines}->{$line}->{$policy_name};
+    return 1 if $self->{_disabled_lines}->{$line}->{ALL};
+    return 0;
+}
+
+#-----------------------------------------------------------------------------
+
 sub _is_a_version_statement {
     my (undef, $element) = @_;
 
@@ -200,6 +229,171 @@ sub _caching_finder {
 
 #-----------------------------------------------------------------------------
 
+sub _find_disabled_lines {
+
+    my ($doc, @site_policies)= @_;
+
+    my $nodes_ref  = $doc->find('PPI::Token::Comment') || return;
+    my %disabled_lines;
+
+    _disable_shebang_line($nodes_ref, \%disabled_lines, \@site_policies);
+    _disable_other_lines($nodes_ref, \%disabled_lines, \@site_policies);
+    return %disabled_lines;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _disable_shebang_line {
+    my ($nodes_ref, $disabled_lines, $site_policies) = @_;
+
+    my $shebang_no_critic  = qr{\A [#]! .*? [#][#] \s* no  \s+ critic}xms;
+
+    # Special case for the very beginning of the file: allow "##no critic" after the shebang
+    if (0 < @{$nodes_ref}) {
+        my $loc = $nodes_ref->[0]->location;
+        if (1 == $loc->[0] && 1 == $loc->[1] && $nodes_ref->[0] =~ $shebang_no_critic) {
+            my $pragma = shift @{$nodes_ref};
+            for my $policy (_parse_nocritic_import($pragma, $site_policies)) {
+                $disabled_lines->{ 1 }->{$policy} = 1;
+            }
+        }
+    }
+    return;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _disable_other_lines {
+    my ($nodes_ref, $disabled_lines, $site_policies) = @_;
+
+    my $no_critic  = qr{\A \s* [#][#] \s* no  \s+ critic}xms;
+    my $use_critic = qr{\A \s* [#][#] \s* use \s+ critic}xms;
+
+  PRAGMA:
+    for my $pragma ( grep { $_ =~ $no_critic } @{$nodes_ref} ) {
+
+        # Parse out the list of Policy names after the
+        # 'no critic' pragma.  I'm thinking of this just
+        # like a an C<import> argument for real pragmas.
+        my @no_policies = _parse_nocritic_import($pragma, $site_policies);
+
+        # Grab surrounding nodes to determine the context.
+        # This determines whether the pragma applies to
+        # the current line or the block that follows.
+        my $parent = $pragma->parent();
+        my $grandparent = $parent ? $parent->parent() : undef;
+        my $sib = $pragma->sprevious_sibling();
+
+
+        # Handle single-line usage on simple statements
+        if ( $sib && $sib->location->[0] == $pragma->location->[0] ) {
+            my $line = $pragma->location->[0];
+            for my $policy ( @no_policies ) {
+                $disabled_lines->{ $line }->{$policy} = 1;
+            }
+            next PRAGMA;
+        }
+
+
+        # Handle single-line usage on compound statements
+        if ( ref $parent eq 'PPI::Structure::Block' ) {
+            if ( ref $grandparent eq 'PPI::Statement::Compound'
+                 || ref $grandparent eq 'PPI::Statement::Sub' ) {
+                if ( $parent->location->[0] == $pragma->location->[0] ) {
+                    my $line = $grandparent->location->[0];
+                    for my $policy ( @no_policies ) {
+                        $disabled_lines->{ $line }->{$policy} = 1;
+                    }
+                    next PRAGMA;
+                }
+            }
+        }
+
+
+        # Handle multi-line usage.  This is either a "no critic" ..
+        # "use critic" region or a block where "no critic" persists
+        # until the end of the scope.  The start is the always the "no
+        # critic" which we already found.  So now we have to search
+        # for the end.
+
+        my $start = $pragma;
+        my $end   = $pragma;
+
+      SIB:
+        while ( my $esib = $end->next_sibling() ) {
+            $end = $esib; # keep track of last sibling encountered in this scope
+            last SIB
+                if $esib->isa('PPI::Token::Comment') && $esib =~ $use_critic;
+        }
+
+        # We either found an end or hit the end of the scope.
+        # Flag all intervening lines
+        for my $line ( $start->location->[0] .. $end->location->[0] ) {
+            for my $policy ( @no_policies ) {
+                $disabled_lines->{ $line }->{$policy} = 1;
+            }
+        }
+    }
+
+    return;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _parse_nocritic_import {
+
+    my ($pragma, $site_policies) = @_;
+
+    my $module    = qr{ [\w:]+ }xms;
+    my $delim     = qr{ \s* [,\s] \s* }xms;
+    my $qw        = qr{ (?: qw )? }xms;
+    my $qualifier = qr{ $qw [(]? \s* ( $module (?: $delim $module)* ) \s* [)]? }xms;
+    my $no_critic = qr{ \#\# \s* no \s+ critic \s* $qualifier }xms;  ##no critic(EscapedMetacharacters)
+
+    if ( my ($module_list) = $pragma =~ $no_critic ) {
+        my @modules = split $delim, $module_list;
+
+        # Compose the specified modules into a regex alternation.  Wrap each
+        # in a no-capturing group to permit "|" in the modules specification
+        # (backward compatibility)
+        my $re = join q{|}, map {"(?:$_)"} @modules;
+        return grep {m/$re/ixms} @{$site_policies};
+    }
+
+    # Default to disabling ALL policies.
+    return qw(ALL);
+}
+
+#-----------------------------------------------------------------------------
+
+sub _unfix_shebang {
+
+    # When you install a script using ExtUtils::MakeMaker or Module::Build, it
+    # inserts some magical code into the top of the file (just after the
+    # shebang).  This code allows people to call your script using a shell,
+    # like `sh my_script`.  Unfortunately, this code causes several Policy
+    # violations, so we just disable it as if a "## no critic" comment had
+    # been attached.
+
+    my $doc         = shift;
+    my $first_stmnt = $doc->schild(0) || return {};
+
+    # Different versions of MakeMaker and Build use slightly different shebang
+    # fixing strings.  This matches most of the ones I've found in my own Perl
+    # distribution, but it may not be bullet-proof.
+
+    my $fixin_rx = qr{^eval 'exec .* \$0 \${1\+"\$@"}'\s*[\r\n]\s*if.+;}ms; ## no critic (RequireExtendedFormatting)
+    if ( $first_stmnt =~ $fixin_rx ) {
+        my $line = $first_stmnt->location()->[0];
+        return { $line => {ALL => 1}, $line + 1 => {ALL => 1} };
+    }
+
+    #No magic shebang was found!
+    return {};
+}
+
+#-----------------------------------------------------------------------------
+
 1;
 
 __END__
@@ -305,6 +499,19 @@ requirement declared in the document via a C<use> or C<require>
 statement.  Returns nothing if there is no version statement.
 
 
+=item C<< mark_disabled_lines( @policy_names ) >>
+
+Scans the document for C<"## no critic"> pseudo-pragmas and builds
+an internal table of which of the listed C<@policy_names> have
+been disabled at each line.  Returns C<$self>.
+
+
+=item C<< line_is_disabled($line, $policy_name) >>
+
+Returns true if the given C<$policy_name> has been disabled for
+at C<$line> in this document.  Otherwise, returns false.
+
+
 =back