vcs.maemo.org Git - dh-make-perl/blob - dev/i386/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Theme.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Theme.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::Theme;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13 use English qw(-no_match_vars);
  14 use Readonly;
  15
  16 use base qw{ Exporter };
  17
  18 use List::MoreUtils qw(any);
  19
  20 use Perl::Critic::Utils qw{ :characters :data_conversion };
  21 use Perl::Critic::Exception::Fatal::Internal qw{ &throw_internal };
  22 use Perl::Critic::Exception::Configuration::Option::Global::ParameterValue
  23     qw{ &throw_global_value };
  24
  25 #-----------------------------------------------------------------------------
  26
  27 our $VERSION = '1.088';
  28
  29 #-----------------------------------------------------------------------------
  30
  31 Readonly::Array our @EXPORT_OK => qw{
  32     $RULE_INVALID_CHARACTER_REGEX
  33     cook_rule
  34 };
  35
  36 #-----------------------------------------------------------------------------
  37
  38 Readonly::Scalar our $RULE_INVALID_CHARACTER_REGEX =>
  39     qr/ ( [^()\s\w\d+\-*&|!] ) /xms;
  40
  41 #-----------------------------------------------------------------------------
  42
  43 Readonly::Scalar my $CONFIG_KEY => 'theme';
  44
  45 #-----------------------------------------------------------------------------
  46
  47 sub new {
  48
  49     my ( $class, %args ) = @_;
  50     my $self = bless {}, $class;
  51     $self->_init( %args );
  52     return $self;
  53 }
  54
  55 #-----------------------------------------------------------------------------
  56
  57 sub _init {
  58
  59     my ($self, %args) = @_;
  60     my $rule = $args{-rule} || $EMPTY;
  61
  62     if ( $rule =~ m/$RULE_INVALID_CHARACTER_REGEX/xms ) {
  63         throw_global_value
  64             option_name     => $CONFIG_KEY,
  65             option_value    => $rule,
  66             message_suffix => qq{contains an invalid character: "$1".};
  67     }
  68
  69     $self->{_rule} = cook_rule( $rule );
  70
  71     return $self;
  72 }
  73
  74 #-----------------------------------------------------------------------------
  75
  76 sub rule {
  77     my $self = shift;
  78     return $self->{_rule};
  79 }
  80
  81 #-----------------------------------------------------------------------------
  82
  83 sub policy_is_thematic {
  84
  85     my ($self, %args) = @_;
  86     my $policy = $args{-policy}
  87         || throw_internal 'The -policy argument is required';
  88     ref $policy
  89         || throw_internal 'The -policy must be an object';
  90
  91     my $rule = $self->{_rule} or return 1;
  92     my %themes = hashify( $policy->get_themes() );
  93
  94     # This bit of magic turns the rule into a perl expression that can be
  95     # eval-ed for truth.  Each theme name in the rule is translated to 1 or 0
  96     # if the $policy belongs in that theme.  For example:
  97     #
  98     # 'bugs && (pbp || core)'  ...could become... '1 && (0 || 1)'
  99
 100     my $as_code = $rule; #Making a copy, so $rule is preserved
 101     $as_code =~ s/ ( [\w\d]+ ) /exists $themes{$1} || 0/gemx;
 102     my $is_thematic = eval $as_code;  ## no critic (ProhibitStringyEval)
 103
 104     if ($EVAL_ERROR) {
 105         throw_global_value
 106             option_name     => $CONFIG_KEY,
 107             option_value    => $rule,
 108             message_suffix  => q{contains a syntax error.};
 109     }
 110
 111     return $is_thematic;
 112 }
 113
 114 #-----------------------------------------------------------------------------
 115
 116 sub cook_rule {
 117     my ($raw_rule) = @_;
 118     return if not defined $raw_rule;
 119
 120     #Translate logical operators
 121     $raw_rule =~ s{\b not \b}{!}ixmg;     # "not" -> "!"
 122     $raw_rule =~ s{\b and \b}{&&}ixmg;    # "and" -> "&&"
 123     $raw_rule =~ s{\b or  \b}{||}ixmg;    # "or"  -> "||"
 124
 125     #Translate algebra operators (for backward compatibility)
 126     $raw_rule =~ s{\A [-] }{!}ixmg;     # "-" -> "!"     e.g. difference
 127     $raw_rule =~ s{   [-] }{&& !}ixmg;  # "-" -> "&& !"  e.g. difference
 128     $raw_rule =~ s{   [*] }{&&}ixmg;    # "*" -> "&&"    e.g. intersection
 129     $raw_rule =~ s{   [+] }{||}ixmg;    # "+" -> "||"    e.g. union
 130
 131     my $cooked_rule = lc $raw_rule;  #Is now cooked!
 132     return $cooked_rule;
 133 }
 134
 135
 136 1;
 137
 138 __END__
 139
 140 #-----------------------------------------------------------------------------
 141
 142 =pod
 143
 144 =head1 NAME
 145
 146 Perl::Critic::Theme - Construct thematic sets of policies.
 147
 148 =head1 DESCRIPTION
 149
 150 This is a helper class for evaluating theme expressions into sets of Policy
 151 objects.  There are no user-serviceable parts here.
 152
 153 =head1 METHODS
 154
 155 =over
 156
 157 =item C<< new( -rule => $rule_expression ) >>
 158
 159 Returns a reference to a new Perl::Critic::Theme object.  C<-rule> is a string
 160 expression that evaluates to true or false for each Policy.. See L<"THEME
 161 RULES"> for more information.
 162
 163 =item C<< policy_is_thematic( -policy => $policy ) >>
 164
 165 Given a reference to a L<Perl::Critic::Policy> object, this method returns
 166 evaluates the rule against the themes that are associated with the Policy.
 167 Returns 1 if the Policy satisfies the rule, 0 otherwise.
 168
 169 =item C< rule() >
 170
 171 Returns the rule expression that was used to construct this Theme.  The rule
 172 may have been translated into a normalized expression.  See L<"THEME RULES">
 173 for more information.
 174
 175 =back
 176
 177 =head2 THEME RULES
 178
 179 A theme rule is a simple boolean expression, where the operands are the names
 180 of any of the themes associated with the Perl::Critic::Polices.
 181
 182 Theme names can be combined with logical operators to form arbitrarily complex
 183 expressions.  Precedence is the same as normal mathematics, but you can use
 184 parentheses to enforce precedence as well.  Supported operators are:
 185
 186    Operator    Altertative    Example
 187    ----------------------------------------------------------------------------
 188    &&          and            'pbp && core'
 189    ||          or             'pbp || (bugs && security)'
 190    !           not            'pbp && ! (portability || complexity)
 191
 192 See L<Perl::Critic/"CONFIGURATION"> for more information about customizing the
 193 themes for each Policy.
 194
 195
 196 =head1 SUBROUTINES
 197
 198 =over
 199
 200 =item C<cook_rule( $rule )>
 201
 202 Standardize a rule into a almost executable Perl code.  The "almost" comes
 203 from the fact that theme names are left as is.
 204
 205
 206 =back
 207
 208
 209 =head1 CONSTANTS
 210
 211 =over
 212
 213 =item C<$RULE_INVALID_CHARACTER_REGEX>
 214
 215 A regular expression that will return the first character in the matched
 216 expression that is not valid in a rule.
 217
 218
 219 =back
 220
 221
 222 =head1 AUTHOR
 223
 224 Jeffrey Thalhammer  <thaljef@cpan.org>
 225
 226 =head1 COPYRIGHT
 227
 228 Copyright (c) 2006-2008 Jeffrey Thalhammer
 229
 230 This program is free software; you can redistribute it and/or modify
 231 it under the same terms as Perl itself.  The full text of this license
 232 can be found in the LICENSE file included with this module.
 233
 234 =cut
 235
 236 ##############################################################################
 237 # Local Variables:
 238 #   mode: cperl
 239 #   cperl-indent-level: 4
 240 #   fill-column: 78
 241 #   indent-tabs-mode: nil
 242 #   c-indentation-style: bsd
 243 # End:
 244 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :