Perl::Critic::Policy - Base class for all Policy modules.

Perl-Critic documentation Contained in the Perl-Critic distribution.

Index

Code Index:

NAME

Top

Perl::Critic::Policy - Base class for all Policy modules.

DESCRIPTION

Top

Perl::Critic::Policy is the abstract base class for all Policy objects. If you're developing your own Policies, your job is to implement and override its methods in a subclass. To work with the Perl::Critic engine, your implementation must behave as described below. For a detailed explanation on how to make new Policy modules, please see the Perl::Critic::DEVELOPER (Perl::Critic::DEVELOPER) document included in this distribution.

INTERFACE SUPPORT

Top

This is considered to be a public class. Any changes to its interface will go through a deprecation cycle.

METHODS

Top

new( ... )

Don't call this. As a Policy author, do not implement this. Use the initialize_if_enabled() method for your Policy setup. See the developer (Perl::Critic::DEVELOPER) documentation for more.

initialize_if_enabled( $config )

This receives an instance of Perl::Critic::PolicyConfig as a parameter, and is only invoked if this Policy is enabled by the user. Thus, this is the preferred place for subclasses to do any initialization.

Implementations of this method should return a boolean value indicating whether the Policy should continue to be enabled. For most subclasses, this will always be $TRUE. Policies that depend upon external modules or other system facilities that may or may not be available should test for the availability of these dependencies and return $FALSE if they are not.

prepare_to_scan_document( $document )

The parameter is about to be scanned by this Policy. Whatever this Policy wants to do in terms of preparation should happen here. Returns a boolean value indicating whether the document should be scanned at all; if this is a false value, this Policy won't be applied to the document. By default, does nothing but return $TRUE.

violates( $element, $document )

Given a PPI::Element and a PPI::Document, returns one or more Perl::Critic::Violation objects if the $element violates this Policy. If there are no violations, then it returns an empty list. If the Policy encounters an exception, then it should croak with an error message and let the caller decide how to handle it.

violates() is an abstract method and it will abort if you attempt to invoke it directly. It is the heart of all Policy modules, and your subclass must override this method.

violation( $description, $explanation, $element )

Returns a reference to a new Perl::Critic::Violation object. The arguments are a description of the violation (as string), an explanation for the policy (as string) or a series of page numbers in PBP (as an ARRAY ref), a reference to the PPI element that caused the violation.

These are the same as the constructor to Perl::Critic::Violation, but without the severity. The Policy itself knows the severity.

new_parameter_value_exception( $option_name, $option_value, $source, $message_suffix )

Create a Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue for this Policy.

throw_parameter_value_exception( $option_name, $option_value, $source, $message_suffix )

Create and throw a Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue. Useful in parameter parser implementations.

get_long_name()

Return the full package name of this policy.

get_short_name()

Return the name of this policy without the "Perl::Critic::Policy::" prefix.

is_enabled()

Answer whether this policy is really active or not. Returns a true value if it is, a false, yet defined, value if it isn't, and an undefined value if it hasn't yet been decided whether it will be.

applies_to()

Returns a list of the names of PPI classes that this Policy cares about. By default, the result is PPI::Element. Overriding this method in Policy subclasses should lead to significant performance increases.

default_maximum_violations_per_document()

Returns the default maximum number of violations for this policy to report per document. By default, this not defined, but subclasses may override this.

get_maximum_violations_per_document()

Returns the maximum number of violations this policy will report for a single document. If this is not defined, then there is no limit. If set_maximum_violations_per_document() has not been invoked, then default_maximum_violations_per_document() is returned.

set_maximum_violations_per_document()

Specify the maximum violations that this policy should report for a document.

default_severity()

Returns the default severity for violating this Policy. See the $SEVERITY constants in Perl::Critic::Utils for an enumeration of possible severity values. By default, this method returns $SEVERITY_LOWEST. Authors of Perl::Critic::Policy subclasses should override this method to return a value that they feel is appropriate for their Policy. In general, Polices that are widely accepted or tend to prevent bugs should have a higher severity than those that are more subjective or cosmetic in nature.

get_severity()

Returns the severity of violating this Policy. If the severity has not been explicitly defined by calling set_severity, then the default_severity is returned. See the $SEVERITY constants in Perl::Critic::Utils for an enumeration of possible severity values.

set_severity( $N )

Sets the severity for violating this Policy. Clients of Perl::Critic::Policy objects can call this method to assign a different severity to the Policy if they don't agree with the default_severity. See the $SEVERITY constants in Perl::Critic::Utils for an enumeration of possible values.

default_themes()

Returns a sorted list of the default themes associated with this Policy. The default method returns an empty list. Policy authors should override this method to return a list of themes that are appropriate for their policy.

get_themes()

Returns a sorted list of the themes associated with this Policy. If you haven't added themes or set the themes explicitly, this method just returns the default themes.

set_themes( @THEME_LIST )

Sets the themes associated with this Policy. Any existing themes are overwritten. Duplicate themes will be removed.

add_themes( @THEME_LIST )

Appends additional themes to this Policy. Any existing themes are preserved. Duplicate themes will be removed.

get_abstract()

Retrieve the abstract for this policy (the part of the NAME section of the POD after the module name), if it is available.

get_raw_abstract()

Retrieve the abstract for this policy (the part of the NAME section of the POD after the module name), if it is available, in the unparsed form.

parameter_metadata_available()

Returns whether information about the parameters is available.

get_parameters()

Returns a reference to an array containing instances of Perl::Critic::PolicyParameter.

Note that this will return an empty list if the parameters for this policy are unknown. In order to differentiate between this circumstance and the one where this policy does not take any parameters, it is necessary to call parameter_metadata_available().

set_format( $format )

Class method. Sets the format for all Policy objects when they are evaluated in string context. The default is "%p\n". See "OVERLOADS" for formatting options.

get_format()

Class method. Returns the current format for all Policy objects when they are evaluated in string context.

to_string()

Returns a string representation of the policy. The content of the string depends on the current value returned by get_format(). See "OVERLOADS" for the details.

is_safe()

Answer whether this Policy can be used to analyze untrusted code, i.e. the Policy doesn't have any potential side effects.

This method returns a true value by default.

An "unsafe" policy might attempt to compile the code, which, if you have BEGIN or CHECK blocks that affect files or connect to databases, is not a safe thing to do. If you are writing a such a Policy, then you should override this method to return false.

By default Perl::Critic will not run unsafe policies.

DOCUMENTATION

Top

When your Policy module first uses Perl::Critic::Violation, it will try and extract the DESCRIPTION section of your Policy module's POD. This information is displayed by Perl::Critic if the verbosity level is set accordingly. Therefore, please include a DESCRIPTION section in the POD for any Policy modules that you author. Thanks.

OVERLOADS

Top

Perl::Critic::Violation overloads the "" operator to produce neat little messages when evaluated in string context.

Formats are a combination of literal and escape characters similar to the way sprintf works. If you want to know the specific formatting capabilities, look at String::Format. Valid escape characters are:

%P

Name of the Policy module.

%p

Name of the Policy without the Perl::Critic::Policy:: prefix.

%a

The policy abstract.

%O

List of supported policy parameters. Takes an option of a format string for "to_formatted_string" in Perl::Critic::PolicyParameter. For example, this can be used like %{%n - %d\n}O to get a list of parameter names followed by their descriptions.

%U

A message stating that the parameters for the policy are unknown if parameter_metadata_available() returns false. Takes an option of what the message should be, which defaults to "Cannot programmatically discover what parameters this policy takes.". The value of this option is interpolated in order to expand the standard escape sequences (\n, \t, etc.).

%S

The default severity level of the policy.

%s

The current severity level of the policy.

%T

The default themes for the policy.

%t

The current themes for the policy.

%V

The default maximum number of violations per document of the policy.

%v

The current maximum number of violations per document of the policy.

AUTHOR

Top

Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>

COPYRIGHT

Top

Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of this license can be found in the LICENSE file included with this module.

Perl-Critic documentation Contained in the Perl-Critic distribution. 
##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/lib/Perl/Critic/Policy.pm $
#     $Date: 2011-05-15 16:34:46 -0500 (Sun, 15 May 2011) $
#   $Author: clonezone $
# $Revision: 4078 $
##############################################################################

package Perl::Critic::Policy;

use 5.006001;
use strict;
use warnings;

use English qw< -no_match_vars >;
use Readonly;

use File::Spec ();
use String::Format qw< stringf >;

use overload ( q<""> => 'to_string', cmp => '_compare' );

use Perl::Critic::Utils qw<
    :characters
    :booleans
    :severities
    :data_conversion
    interpolate
    is_integer
    policy_long_name
    policy_short_name
    severity_to_number
>;
use Perl::Critic::Utils::DataConversion qw< dor >;
use Perl::Critic::Utils::POD qw<
    get_module_abstract_for_module
    get_raw_module_abstract_for_module
>;
use Perl::Critic::Exception::AggregateConfiguration;
use Perl::Critic::Exception::Configuration;
use Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter;
use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue;
use Perl::Critic::Exception::Fatal::PolicyDefinition
    qw< throw_policy_definition >;
use Perl::Critic::PolicyConfig qw<>;
use Perl::Critic::PolicyParameter qw<>;
use Perl::Critic::Violation qw<>;

use Exception::Class;   # this must come after "use P::C::Exception::*"

our $VERSION = '1.116';

#-----------------------------------------------------------------------------

Readonly::Scalar my $NO_LIMIT => 'no_limit';

#-----------------------------------------------------------------------------

my $format = "%p\n"; #Default stringy format

#-----------------------------------------------------------------------------

sub new {
    my ($class, %config) = @_;

    my $self = bless {}, $class;

    my $config_object;
    if ($config{_config_object}) {
        $config_object = $config{_config_object};
    }
    else {
        $config_object =
            Perl::Critic::PolicyConfig->new(
                $self->get_short_name(),
                \%config,
            );
    }

    $self->__set_config( $config_object );

    my @parameters;
    my $parameter_metadata_available = 0;

    if ( $class->can('supported_parameters') ) {
        $parameter_metadata_available = 1;
        @parameters =
            map
                { Perl::Critic::PolicyParameter->new($_) }
                $class->supported_parameters();
    }
    $self->{_parameter_metadata_available} = $parameter_metadata_available;
    $self->{_parameters} = \@parameters;

    my $errors = Perl::Critic::Exception::AggregateConfiguration->new();
    foreach my $parameter ( @parameters ) {
        eval {
            $parameter->parse_and_validate_config_value( $self, $config_object );
        }
            or do {
                $errors->add_exception_or_rethrow($EVAL_ERROR);
            };

        $config_object->remove( $parameter->get_name() );
    }

    if ($parameter_metadata_available) {
        $config_object->handle_extra_parameters( $self, $errors );
    }

    if ( $errors->has_exceptions() ) {
        $errors->rethrow();
    }

    return $self;
}

#-----------------------------------------------------------------------------

sub is_safe {
    return $TRUE;
}

#-----------------------------------------------------------------------------

sub initialize_if_enabled {
    return $TRUE;
}

#-----------------------------------------------------------------------------

sub prepare_to_scan_document {
    return $TRUE;
}

#-----------------------------------------------------------------------------

sub __get_parameter_name {
    my ( $self, $parameter ) = @_;

    return '_' . $parameter->get_name();
}

#-----------------------------------------------------------------------------

sub __set_parameter_value {
    my ( $self, $parameter, $value ) = @_;

    $self->{ $self->__get_parameter_name($parameter) } = $value;

    return;
}

#-----------------------------------------------------------------------------

sub __set_base_parameters {
    my ($self) = @_;

    my $config = $self->__get_config();
    my $errors = Perl::Critic::Exception::AggregateConfiguration->new();

    $self->_set_maximum_violations_per_document($errors);

    my $user_severity = $config->get_severity();
    if ( defined $user_severity ) {
        my $normalized_severity = severity_to_number( $user_severity );
        $self->set_severity( $normalized_severity );
    }

    my $user_set_themes = $config->get_set_themes();
    if ( defined $user_set_themes ) {
        my @set_themes = words_from_string( $user_set_themes );
        $self->set_themes( @set_themes );
    }

    my $user_add_themes = $config->get_add_themes();
    if ( defined $user_add_themes ) {
        my @add_themes = words_from_string( $user_add_themes );
        $self->add_themes( @add_themes );
    }

    if ( $errors->has_exceptions() ) {
        $errors->rethrow();
    }

    return;
}

#-----------------------------------------------------------------------------

sub _set_maximum_violations_per_document {
    my ($self, $errors) = @_;

    my $config = $self->__get_config();

    if ( $config->is_maximum_violations_per_document_unlimited() ) {
        return;
    }

    my $user_maximum_violations =
        $config->get_maximum_violations_per_document();

    if ( not is_integer($user_maximum_violations) ) {
        $errors->add_exception(
            new_parameter_value_exception(
                'maximum_violations_per_document',
                $user_maximum_violations,
                undef,
                "does not look like an integer.\n"
            )
        );

        return;
    }
    elsif ( $user_maximum_violations < 0 ) {
        $errors->add_exception(
            new_parameter_value_exception(
                'maximum_violations_per_document',
                $user_maximum_violations,
                undef,
                "is not greater than or equal to zero.\n"
            )
        );

        return;
    }

    $self->set_maximum_violations_per_document(
        $user_maximum_violations
    );

    return;
}

#-----------------------------------------------------------------------------

# Unparsed configuration, P::C::PolicyConfig.  Compare with get_parameters().
sub __get_config {
    my ($self) = @_;

    return $self->{_config};
}

sub __set_config {
    my ($self, $config) = @_;

    $self->{_config} = $config;

    return;
}

 #-----------------------------------------------------------------------------

sub get_long_name {
    my ($self) = @_;

    return policy_long_name(ref $self);
}

#-----------------------------------------------------------------------------

sub get_short_name {
    my ($self) = @_;

    return policy_short_name(ref $self);
}

#-----------------------------------------------------------------------------

sub is_enabled {
    my ($self) = @_;

    return $self->{_enabled};
}

#-----------------------------------------------------------------------------

sub __set_enabled {
    my ($self, $new_value) = @_;

    $self->{_enabled} = $new_value;

    return;
}

#-----------------------------------------------------------------------------

sub applies_to {
    return qw(PPI::Element);
}

#-----------------------------------------------------------------------------

sub set_maximum_violations_per_document {
    my ($self, $maximum_violations_per_document) = @_;

    $self->{_maximum_violations_per_document} =
        $maximum_violations_per_document;

    return $self;
}

#-----------------------------------------------------------------------------

sub get_maximum_violations_per_document {
    my ($self) = @_;

    return
        exists $self->{_maximum_violations_per_document}
            ? $self->{_maximum_violations_per_document}
            : $self->default_maximum_violations_per_document();
}

#-----------------------------------------------------------------------------

sub default_maximum_violations_per_document {
    return;
}

#-----------------------------------------------------------------------------

sub set_severity {
    my ($self, $severity) = @_;
    $self->{_severity} = $severity;
    return $self;
}

#-----------------------------------------------------------------------------

sub get_severity {
    my ($self) = @_;
    return $self->{_severity} || $self->default_severity();
}

#-----------------------------------------------------------------------------

sub default_severity {
    return $SEVERITY_LOWEST;
}

#-----------------------------------------------------------------------------

sub set_themes {
    my ($self, @themes) = @_;
    $self->{_themes} = [ sort @themes ];
    return $self;
}

#-----------------------------------------------------------------------------

sub get_themes {
    my ($self) = @_;
    my @themes = defined $self->{_themes} ? @{ $self->{_themes} } : $self->default_themes();
    my @sorted_themes = sort @themes;
    return @sorted_themes;
}

#-----------------------------------------------------------------------------

sub add_themes {
    my ($self, @additional_themes) = @_;
    #By hashifying the themes, we squish duplicates
    my %merged = hashify( $self->get_themes(), @additional_themes);
    $self->{_themes} = [ keys %merged];
    return $self;
}

#-----------------------------------------------------------------------------

sub default_themes {
    return ();
}

#-----------------------------------------------------------------------------

sub get_abstract {
    my ($self) = @_;

    return get_module_abstract_for_module( ref $self );
}

#-----------------------------------------------------------------------------

sub get_raw_abstract {
    my ($self) = @_;

    return get_raw_module_abstract_for_module( ref $self );
}

#-----------------------------------------------------------------------------

sub parameter_metadata_available {
    my ($self) = @_;

    return $self->{_parameter_metadata_available};
}

#-----------------------------------------------------------------------------

sub get_parameters {
    my ($self) = @_;

    return $self->{_parameters};
}

#-----------------------------------------------------------------------------

sub violates {
    my ($self) = @_;

    return throw_policy_definition
        $self->get_short_name() . q/ does not implement violates()./;
}

#-----------------------------------------------------------------------------

sub violation {  ## no critic (ArgUnpacking)
    my ( $self, $desc, $expl, $elem ) = @_;
    # HACK!! Use goto instead of an explicit call because P::C::V::new() uses caller()
    my $sev = $self->get_severity();
    @_ = ('Perl::Critic::Violation', $desc, $expl, $elem, $sev );
    goto &Perl::Critic::Violation::new;
}

#-----------------------------------------------------------------------------

sub new_parameter_value_exception {
    my ( $self, $option_name, $option_value, $source, $message_suffix ) = @_;

    return Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue->new(
        policy          => $self->get_short_name(),
        option_name     => $option_name,
        option_value    => $option_value,
        source          => $source,
        message_suffix  => $message_suffix
    );
}

#-----------------------------------------------------------------------------

## no critic (Subroutines::RequireFinalReturn)
sub throw_parameter_value_exception {
    my ( $self, $option_name, $option_value, $source, $message_suffix ) = @_;

    $self->new_parameter_value_exception(
        $option_name, $option_value, $source, $message_suffix
    )
        ->throw();
}
## use critic


#-----------------------------------------------------------------------------

# Static methods.

sub set_format { return $format = $_[0] }  ## no critic(ArgUnpacking)
sub get_format { return $format         }

#-----------------------------------------------------------------------------

sub to_string {
    my ($self, @args) = @_;

    # Wrap the more expensive ones in sub{} to postpone evaluation
    my %fspec = (
         'P' => sub { $self->get_long_name() },
         'p' => sub { $self->get_short_name() },
         'a' => sub { dor($self->get_abstract(), $EMPTY) },
         'O' => sub { $self->_format_parameters(@_) },
         'U' => sub { $self->_format_lack_of_parameter_metadata(@_) },
         'S' => sub { $self->default_severity() },
         's' => sub { $self->get_severity() },
         'T' => sub { join $SPACE, $self->default_themes() },
         't' => sub { join $SPACE, $self->get_themes() },
         'V' => sub { dor( $self->default_maximum_violations_per_document(), $NO_LIMIT ) },
         'v' => sub { dor( $self->get_maximum_violations_per_document(), $NO_LIMIT ) },
    );
    return stringf(get_format(), %fspec);
}

sub _format_parameters {
    my ($self, $parameter_format) = @_;

    return $EMPTY if not $self->parameter_metadata_available();

    my $separator;
    if ($parameter_format) {
        $separator = $EMPTY;
    } else {
        $separator = $SPACE;
        $parameter_format = '%n';
    }

    return
        join
            $separator,
            map { $_->to_formatted_string($parameter_format) } @{ $self->get_parameters() };
}

sub _format_lack_of_parameter_metadata {
    my ($self, $message) = @_;

    return $EMPTY if $self->parameter_metadata_available();
    return interpolate($message) if $message;

    return
        'Cannot programmatically discover what parameters this policy takes.';
}

#-----------------------------------------------------------------------------
# Apparently, some perls do not implicitly stringify overloading
# objects before doing a comparison.  This causes a couple of our
# sorting tests to fail.  To work around this, we overload C<cmp> to
# do it explicitly.
#
# 20060503 - More information:  This problem has been traced to
# Test::Simple versions <= 0.60, not perl itself.  Upgrading to
# Test::Simple v0.62 will fix the problem.  But rather than forcing
# everyone to upgrade, I have decided to leave this workaround in
# place.

sub _compare { return "$_[0]" cmp "$_[1]" }

1;

__END__

#-----------------------------------------------------------------------------


# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 78
#   indent-tabs-mode: nil
#   c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :