vcs.maemo.org Git - dh-make-perl/blob - dev/arm/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm $
   3 #     $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
   4 #   $Author: clonezone $
   5 # $Revision: 2489 $
   6 ##############################################################################
   7
   8 package Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13
  14 use Readonly;
  15
  16 use Perl::Critic::Utils qw< :characters :severities >;
  17 use base 'Perl::Critic::Policy';
  18
  19 our $VERSION = '1.088';
  20
  21 #-----------------------------------------------------------------------------
  22
  23 Readonly::Scalar my $EXPL =>
  24     q{"use English" without the '-no_match_vars' argument degrades performance.'};
  25 Readonly::Scalar my $DESC => q{"use English" without '-no_match_vars' argument};
  26
  27 #-----------------------------------------------------------------------------
  28
  29 sub supported_parameters { return ()                        }
  30 sub default_severity     { return $SEVERITY_LOW             }
  31 sub default_themes       { return qw( core performance )    }
  32 sub applies_to           { return 'PPI::Statement::Include' }
  33
  34 #-----------------------------------------------------------------------------
  35
  36 sub violates {
  37     my ( $self, $elem, $doc ) = @_;
  38
  39     # "require"ing English is kind of useless.
  40     return if $elem->type() ne 'use';
  41     return if $elem->module() ne 'English';
  42
  43     my @elements = $elem->schildren();
  44     shift @elements; # dump "use"
  45     shift @elements; # dump "English"
  46
  47     if (not @elements) {
  48         return $self->violation($DESC, $EXPL, $elem);
  49     }
  50
  51     _skip_version_number( \@elements );
  52
  53     @elements = _descend_into_parenthesized_list_if_present(@elements);
  54
  55     if (not @elements) {
  56         return $self->violation($DESC, $EXPL, $elem);
  57     }
  58
  59     my $current_element = $elements[0];
  60
  61     while ( $current_element ) {
  62         if ( $current_element->isa('PPI::Token::Quote') ) {
  63             return if $current_element->string() eq '-no_match_vars';
  64         }
  65         elsif ( $current_element->isa('PPI::Token::QuoteLike::Words') ) {
  66             return if $current_element->content() =~ m/-no_match_vars \b/xms;
  67         }
  68         elsif (
  69                 not $current_element->isa('PPI::Token::Operator')
  70             or  $current_element->content() ne $COMMA
  71             and $current_element->content() ne $FATCOMMA
  72         ) {
  73             return $self->violation($DESC, $EXPL, $elem);
  74         }
  75
  76         shift @elements;
  77         $current_element = $elements[0];
  78     }
  79
  80     return $self->violation($DESC, $EXPL, $elem);
  81 }
  82
  83
  84 sub _skip_version_number {
  85     my ($elements_ref) = @_;
  86
  87     my $current_element = $elements_ref->[0];
  88
  89     if ( $current_element->isa('PPI::Token::Number') ) {
  90         shift @{$elements_ref};
  91     }
  92     elsif (
  93             @{$elements_ref} >= 2
  94         and $current_element->isa('PPI::Token::Word')
  95         and $current_element->content() =~ m/\A v \d+ \z/xms
  96         and $elements_ref->[1]->isa('PPI::Token::Number')
  97     ) {
  98         # The above messy conditional necessary due to PPI not handling
  99         # v-strings.
 100         shift @{$elements_ref};
 101         shift @{$elements_ref};
 102     }
 103
 104     return;
 105 }
 106
 107 sub _descend_into_parenthesized_list_if_present {
 108     my @elements = @_;
 109
 110     return if not @elements;
 111
 112     my $current_element = $elements[0];
 113
 114     if ( $current_element->isa('PPI::Structure::List') ) {
 115         my @grand_children = $current_element->schildren();
 116         if (not @grand_children) {
 117             return;
 118         }
 119
 120         my $grand_child = $grand_children[0];
 121
 122         if ( $grand_child->isa('PPI::Statement::Expression') ) {
 123             my @great_grand_children = $grand_child->schildren();
 124
 125             if (not @great_grand_children) {
 126                 return;
 127             }
 128
 129             return @great_grand_children;
 130         }
 131         else {
 132             return @grand_children;
 133         }
 134     }
 135
 136     return @elements;
 137 }
 138
 139 1;
 140
 141 __END__
 142
 143 #-----------------------------------------------------------------------------
 144
 145 =pod
 146
 147 =head1 NAME
 148
 149 Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish - C<use English> must be passed a C<-no_match_vars> argument.
 150
 151
 152 =head1 AFFILIATION
 153
 154 This Policy is part of the core L<Perl::Critic> distribution.
 155
 156
 157 =head1 DESCRIPTION
 158
 159 Due to unfortunate history, if you use the L<English> module but don't
 160 pass in a C<-no_match_vars> argument, all regular expressions in the
 161 entire program, not merely the module in question, suffer a
 162 significant performance penalty.  See the L<English> documentation for
 163 details.
 164
 165   use English;                              # not ok
 166   use English '-no_match_vars';             # ok
 167   use English qw< $ERRNO -no_match_vars>;   # ok
 168
 169
 170
 171 =head1 CONFIGURATION
 172
 173 This Policy is not configurable except for the standard options.
 174
 175
 176 =head1 AUTHOR
 177
 178 Elliot Shank C<< <perl@galumph.com> >>
 179
 180
 181 =head1 COPYRIGHT
 182
 183 Copyright (c) 2008-2008 Elliot Shank.  All rights reserved.
 184
 185 This program is free software; you can redistribute it and/or modify
 186 it under the same terms as Perl itself.  The full text of this license
 187 can be found in the LICENSE file included with this module.
 188
 189
 190 =cut
 191
 192 # Local Variables:
 193 #   mode: cperl
 194 #   cperl-indent-level: 4
 195 #   fill-column: 78
 196 #   indent-tabs-mode: nil
 197 #   c-indentation-style: bsd
 198 # End:
 199 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :