1 ##############################################################################
2 # $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy.pm $
3 # $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
6 ##############################################################################
8 package Perl::Critic::Policy;
14 use English qw< -no_match_vars >;
18 use String::Format qw< stringf >;
20 use overload ( q<""> => 'to_string', cmp => '_compare' );
22 use Perl::Critic::Utils qw<
33 use Perl::Critic::Utils::DataConversion qw< dor >;
34 use Perl::Critic::Utils::POD qw<
35 get_module_abstract_for_module
36 get_raw_module_abstract_for_module
38 use Perl::Critic::Exception::AggregateConfiguration;
39 use Perl::Critic::Exception::Configuration;
40 use Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter;
41 use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue;
42 use Perl::Critic::Exception::Fatal::PolicyDefinition
43 qw< throw_policy_definition >;
44 use Perl::Critic::PolicyConfig qw<>;
45 use Perl::Critic::PolicyParameter qw<>;
46 use Perl::Critic::Violation qw<>;
48 use Exception::Class; # this must come after "use P::C::Exception::*"
50 our $VERSION = '1.088';
52 #-----------------------------------------------------------------------------
54 Readonly::Scalar my $NO_LIMIT => 'no_limit';
56 #-----------------------------------------------------------------------------
58 my $FORMAT = "%p\n"; #Default stringy format
60 #-----------------------------------------------------------------------------
63 my ($class, %config) = @_;
65 my $self = bless {}, $class;
68 if ($config{_config_object}) {
69 $config_object = $config{_config_object};
73 Perl::Critic::PolicyConfig->new(
74 $self->get_short_name(),
79 $self->__set_config( $config_object );
82 my $parameter_metadata_available = 0;
84 if ( $class->can('supported_parameters') ) {
85 $parameter_metadata_available = 1;
88 { Perl::Critic::PolicyParameter->new($_) }
89 $class->supported_parameters();
91 $self->{_parameter_metadata_available} = $parameter_metadata_available;
92 $self->{_parameters} = \@parameters;
94 my $errors = Perl::Critic::Exception::AggregateConfiguration->new();
95 foreach my $parameter ( @parameters ) {
97 $parameter->parse_and_validate_config_value( $self, $config_object );
100 $errors->add_exception_or_rethrow($EVAL_ERROR);
103 $config_object->remove( $parameter->get_name() );
106 if ($parameter_metadata_available) {
107 $self->_validate_config_keys($errors, $config_object);
110 if ( $errors->has_exceptions() ) {
117 #-----------------------------------------------------------------------------
119 sub initialize_if_enabled {
123 #-----------------------------------------------------------------------------
125 sub _validate_config_keys {
126 my ( $self, $errors, $config ) = @_;
128 for my $offered_param ( $config->get_parameter_names() ) {
129 $errors->add_exception(
130 Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter->new(
131 policy => $self->get_short_name(),
132 option_name => $offered_param,
141 #-----------------------------------------------------------------------------
143 sub __get_parameter_name {
144 my ( $self, $parameter ) = @_;
146 return '_' . $parameter->get_name();
149 #-----------------------------------------------------------------------------
151 sub __set_parameter_value {
152 my ( $self, $parameter, $value ) = @_;
154 $self->{ $self->__get_parameter_name($parameter) } = $value;
159 #-----------------------------------------------------------------------------
161 sub __set_base_parameters {
164 my $config = $self->__get_config();
165 my $errors = Perl::Critic::Exception::AggregateConfiguration->new();
167 $self->_set_maximum_violations_per_document($errors);
169 my $user_severity = $config->get_severity();
170 if ( defined $user_severity ) {
171 my $normalized_severity = severity_to_number( $user_severity );
172 $self->set_severity( $normalized_severity );
175 my $user_set_themes = $config->get_set_themes();
176 if ( defined $user_set_themes ) {
177 my @set_themes = words_from_string( $user_set_themes );
178 $self->set_themes( @set_themes );
181 my $user_add_themes = $config->get_add_themes();
182 if ( defined $user_add_themes ) {
183 my @add_themes = words_from_string( $user_add_themes );
184 $self->add_themes( @add_themes );
187 if ( $errors->has_exceptions() ) {
194 #-----------------------------------------------------------------------------
196 sub _set_maximum_violations_per_document {
197 my ($self, $errors) = @_;
199 my $config = $self->__get_config();
201 if ( $config->is_maximum_violations_per_document_unlimited() ) {
205 my $user_maximum_violations =
206 $config->get_maximum_violations_per_document();
208 if ( not is_integer($user_maximum_violations) ) {
209 $errors->add_exception(
210 new_parameter_value_exception(
211 'maximum_violations_per_document',
212 $user_maximum_violations,
214 "does not look like an integer.\n"
220 elsif ( $user_maximum_violations < 0 ) {
221 $errors->add_exception(
222 new_parameter_value_exception(
223 'maximum_violations_per_document',
224 $user_maximum_violations,
226 "is not greater than or equal to zero.\n"
233 $self->set_maximum_violations_per_document(
234 $user_maximum_violations
240 #-----------------------------------------------------------------------------
242 # Unparsed configuration, P::C::PolicyConfig. Compare with get_parameters().
246 return $self->{_config};
250 my ($self, $config) = @_;
252 $self->{_config} = $config;
257 #-----------------------------------------------------------------------------
262 return policy_long_name(ref $self);
265 #-----------------------------------------------------------------------------
270 return policy_short_name(ref $self);
273 #-----------------------------------------------------------------------------
276 return qw(PPI::Element);
279 #-----------------------------------------------------------------------------
281 sub set_maximum_violations_per_document {
282 my ($self, $maximum_violations_per_document) = @_;
284 $self->{_maximum_violations_per_document} =
285 $maximum_violations_per_document;
290 #-----------------------------------------------------------------------------
292 sub get_maximum_violations_per_document {
296 exists $self->{_maximum_violations_per_document}
297 ? $self->{_maximum_violations_per_document}
298 : $self->default_maximum_violations_per_document();
301 #-----------------------------------------------------------------------------
303 sub default_maximum_violations_per_document {
307 #-----------------------------------------------------------------------------
310 my ($self, $severity) = @_;
311 $self->{_severity} = $severity;
315 #-----------------------------------------------------------------------------
319 return $self->{_severity} || $self->default_severity();
322 #-----------------------------------------------------------------------------
324 sub default_severity {
325 return $SEVERITY_LOWEST;
328 #-----------------------------------------------------------------------------
331 my ($self, @themes) = @_;
332 $self->{_themes} = [ sort @themes ];
336 #-----------------------------------------------------------------------------
340 return sort @{ $self->{_themes} } if defined $self->{_themes};
341 return sort $self->default_themes();
344 #-----------------------------------------------------------------------------
347 my ($self, @additional_themes) = @_;
348 #By hashifying the themes, we squish duplicates
349 my %merged = hashify( $self->get_themes(), @additional_themes);
350 $self->{_themes} = [ keys %merged];
354 #-----------------------------------------------------------------------------
360 #-----------------------------------------------------------------------------
365 return get_module_abstract_for_module( ref $self );
368 #-----------------------------------------------------------------------------
370 sub get_raw_abstract {
373 return get_raw_module_abstract_for_module( ref $self );
376 #-----------------------------------------------------------------------------
378 sub parameter_metadata_available {
381 return $self->{_parameter_metadata_available};
384 #-----------------------------------------------------------------------------
389 return $self->{_parameters};
392 #-----------------------------------------------------------------------------
397 return throw_policy_definition
398 $self->get_short_name() . q/ does not implement violates()./;
401 #-----------------------------------------------------------------------------
403 sub violation { ##no critic(ArgUnpacking)
404 my ( $self, $desc, $expl, $elem ) = @_;
405 # HACK!! Use goto instead of an explicit call because P::C::V::new() uses caller()
406 my $sev = $self->get_severity();
407 @_ = ('Perl::Critic::Violation', $desc, $expl, $elem, $sev );
408 goto &Perl::Critic::Violation::new;
411 #-----------------------------------------------------------------------------
413 sub new_parameter_value_exception {
414 my ( $self, $option_name, $option_value, $source, $message_suffix ) = @_;
416 return Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue->new(
417 policy => $self->get_short_name(),
418 option_name => $option_name,
419 option_value => $option_value,
421 message_suffix => $message_suffix
426 #-----------------------------------------------------------------------------
428 ## no critic (Subroutines::RequireFinalReturn)
429 sub throw_parameter_value_exception {
430 my ( $self, $option_name, $option_value, $source, $message_suffix ) = @_;
432 $self->new_parameter_value_exception(
433 $option_name, $option_value, $source, $message_suffix
440 #-----------------------------------------------------------------------------
444 sub set_format { return $FORMAT = $_[0] } ##no critic(ArgUnpacking)
445 sub get_format { return $FORMAT }
447 #-----------------------------------------------------------------------------
450 my ($self, @args) = @_;
452 # Wrap the more expensive ones in sub{} to postpone evaluation
454 'P' => sub { $self->get_long_name() },
455 'p' => sub { $self->get_short_name() },
456 'a' => sub { dor($self->get_abstract(), $EMPTY) },
457 'O' => sub { $self->_format_parameters(@_) },
458 'U' => sub { $self->_format_lack_of_parameter_metadata(@_) },
459 'S' => sub { $self->default_severity() },
460 's' => sub { $self->get_severity() },
461 'T' => sub { join $SPACE, $self->default_themes() },
462 't' => sub { join $SPACE, $self->get_themes() },
463 'V' => sub { dor( $self->default_maximum_violations_per_document(), $NO_LIMIT ) },
464 'v' => sub { dor( $self->get_maximum_violations_per_document(), $NO_LIMIT ) },
466 return stringf($FORMAT, %fspec);
469 sub _format_parameters {
470 my ($self, $format) = @_;
472 return $EMPTY if not $self->parameter_metadata_available();
485 map { $_->to_formatted_string($format) } @{ $self->get_parameters() };
488 sub _format_lack_of_parameter_metadata {
489 my ($self, $message) = @_;
491 return $EMPTY if $self->parameter_metadata_available();
492 return interpolate($message) if $message;
495 'Cannot programmatically discover what parameters this policy takes.';
498 sub _get_source_file {
502 File::Spec->catfile( split m/::/xms, ref $self ) . '.pm';
504 return $INC{$relative_path};
508 #-----------------------------------------------------------------------------
509 # Apparently, some perls do not implicitly stringify overloading
510 # objects before doing a comparison. This causes a couple of our
511 # sorting tests to fail. To work around this, we overload C<cmp> to
514 # 20060503 - More information: This problem has been traced to
515 # Test::Simple versions <= 0.60, not perl itself. Upgrading to
516 # Test::Simple v0.62 will fix the problem. But rather than forcing
517 # everyone to upgrade, I have decided to leave this workaround in
520 sub _compare { return "$_[0]" cmp "$_[1]" }
526 #-----------------------------------------------------------------------------
532 Perl::Critic::Policy - Base class for all Policy modules.
537 Perl::Critic::Policy is the abstract base class for all Policy
538 objects. If you're developing your own Policies, your job is to
539 implement and override its methods in a subclass. To work with the
540 L<Perl::Critic> engine, your implementation must behave as described
541 below. For a detailed explanation on how to make new Policy modules,
542 please see the L<Perl::Critic::DEVELOPER> document included in this
550 =item C<< new(key1 => value1, key2 => value2 ... ) >>
552 Returns a reference to a new subclass of Perl::Critic::Policy. If your
553 Policy requires any special arguments, they will be passed in here as
554 key-value pairs. Users of L<perlcritic> can specify these in their
555 config file. Unless you override the C<new> method, the default
556 method simply returns a reference to an empty hash that has been
557 blessed into your subclass. However, you really should not override
558 this; override C<initialize_if_enabled()> instead.
560 This constructor is always called regardless of whether the user has
561 enabled this Policy or not.
564 =item C<< initialize_if_enabled( { key1 => value1, key2 => value2 ... } ) >>
566 This receives the same parameters as C<new()>, but as a reference to a
567 hash, and is only invoked if this Policy is enabled by the user.
568 Thus, this is the preferred place for subclasses to do any
571 Implementations of this method should return a boolean value
572 indicating whether the Policy should continue to be enabled. For most
573 subclasses, this will always be C<$TRUE>. Policies that depend upon
574 external modules or other system facilities that may or may not be
575 available should test for the availability of these dependencies and
576 return C<$FALSE> if they are not.
579 =item C< violates( $element, $document ) >
581 Given a L<PPI::Element> and a L<PPI::Document>, returns one or more
582 L<Perl::Critic::Violation> objects if the C<$element> violates this
583 Policy. If there are no violations, then it returns an empty list.
584 If the Policy encounters an exception, then it should C<croak> with an
585 error message and let the caller decide how to handle it.
587 C<violates()> is an abstract method and it will abort if you attempt
588 to invoke it directly. It is the heart of all Policy modules, and
589 your subclass B<must> override this method.
592 =item C< violation( $description, $explanation, $element ) >
594 Returns a reference to a new C<Perl::Critic::Violation> object. The
595 arguments are a description of the violation (as string), an
596 explanation for the policy (as string) or a series of page numbers in
597 PBP (as an ARRAY ref), a reference to the L<PPI> element that caused
600 These are the same as the constructor to L<Perl::Critic::Violation>,
601 but without the severity. The Policy itself knows the severity.
604 =item C< new_parameter_value_exception( $option_name, $option_value, $source, $message_suffix ) >
607 L<Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue>
611 =item C< throw_parameter_value_exception( $option_name, $option_value, $source, $message_suffix ) >
614 L<Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue>.
615 Useful in parameter parser implementations.
618 =item C< get_long_name() >
620 Return the full package name of this policy.
623 =item C< get_short_name() >
625 Return the name of this policy without the "Perl::Critic::Policy::"
629 =item C< applies_to() >
631 Returns a list of the names of PPI classes that this Policy cares
632 about. By default, the result is C<PPI::Element>. Overriding this
633 method in Policy subclasses should lead to significant performance
637 =item C< default_maximum_violations_per_document() >
639 Returns the default maximum number of violations for this policy to
640 report per document. By default, this not defined, but subclasses may
644 =item C< get_maximum_violations_per_document() >
646 Returns the maximum number of violations this policy will report for a
647 single document. If this is not defined, then there is no limit. If
648 L<set_maximum_violations_per_document()> has not been invoked, then
649 L<default_maximum_violations_per_document()> is returned.
652 =item C< set_maximum_violations_per_document() >
654 Specify the maximum violations that this policy should report for a
658 =item C< default_severity() >
660 Returns the default severity for violating this Policy. See the
661 C<$SEVERITY> constants in L<Perl::Critic::Utils> for an enumeration of
662 possible severity values. By default, this method returns
663 C<$SEVERITY_LOWEST>. Authors of Perl::Critic::Policy subclasses
664 should override this method to return a value that they feel is
665 appropriate for their Policy. In general, Polices that are widely
666 accepted or tend to prevent bugs should have a higher severity than
667 those that are more subjective or cosmetic in nature.
670 =item C< get_severity() >
672 Returns the severity of violating this Policy. If the severity has
673 not been explicitly defined by calling C<set_severity>, then the
674 C<default_severity> is returned. See the C<$SEVERITY> constants in
675 L<Perl::Critic::Utils> for an enumeration of possible severity values.
678 =item C< set_severity( $N ) >
680 Sets the severity for violating this Policy. Clients of
681 Perl::Critic::Policy objects can call this method to assign a
682 different severity to the Policy if they don't agree with the
683 C<default_severity>. See the C<$SEVERITY> constants in
684 L<Perl::Critic::Utils> for an enumeration of possible values.
687 =item C< default_themes() >
689 Returns a sorted list of the default themes associated with this
690 Policy. The default method returns an empty list. Policy authors
691 should override this method to return a list of themes that are
692 appropriate for their policy.
695 =item C< get_themes() >
697 Returns a sorted list of the themes associated with this Policy. If
698 you haven't added themes or set the themes explicitly, this method
699 just returns the default themes.
702 =item C< set_themes( @THEME_LIST ) >
704 Sets the themes associated with this Policy. Any existing themes are
705 overwritten. Duplicate themes will be removed.
708 =item C< add_themes( @THEME_LIST ) >
710 Appends additional themes to this Policy. Any existing themes are
711 preserved. Duplicate themes will be removed.
714 =item C< get_abstract() >
716 Retrieve the abstract for this policy (the part of the NAME section of
717 the POD after the module name), if it is available.
720 =item C< get_raw_abstract() >
722 Retrieve the abstract for this policy (the part of the NAME section of
723 the POD after the module name), if it is available, in the unparsed
727 =item C< parameter_metadata_available() >
729 Returns whether information about the parameters is available.
732 =item C< get_parameters() >
734 Returns a reference to an array containing instances of
735 L<Perl::Critic::PolicyParameter>.
737 Note that this will return an empty list if the parameters for this
738 policy are unknown. In order to differentiate between this
739 circumstance and the one where this policy does not take any
740 parameters, it is necessary to call C<parameter_metadata_available()>.
743 =item C< get_parameter( $parameter_name ) >
745 Returns the L<Perl::Critic::PolicyParameter> with the specified name.
748 =item C<set_format( $FORMAT )>
750 Class method. Sets the format for all Policy objects when they are
751 evaluated in string context. The default is C<"%p\n">. See
752 L<"OVERLOADS"> for formatting options.
755 =item C<get_format()>
757 Class method. Returns the current format for all Policy objects when
758 they are evaluated in string context.
763 Returns a string representation of the policy. The content of the
764 string depends on the current value of the C<$FORMAT> package
765 variable. See L<"OVERLOADS"> for the details.
773 When your Policy module first C<use>s L<Perl::Critic::Violation>, it
774 will try and extract the DESCRIPTION section of your Policy module's
775 POD. This information is displayed by Perl::Critic if the verbosity
776 level is set accordingly. Therefore, please include a DESCRIPTION
777 section in the POD for any Policy modules that you author. Thanks.
782 Perl::Critic::Violation overloads the C<""> operator to produce neat
783 little messages when evaluated in string context. The format depends
784 on the current value of the C<$FORMAT> package variable.
786 Formats are a combination of literal and escape characters similar to
787 the way C<sprintf> works. If you want to know the specific formatting
788 capabilities, look at L<String::Format>. Valid escape characters are:
795 Name of the Policy module.
800 Name of the Policy without the C<Perl::Critic::Policy::> prefix.
810 List of supported policy parameters. Takes an option of a format
811 string for L<Perl::Critic::PolicyParameter/"to_formatted_string">.
812 For example, this can be used like C<%{%n - %d\n}O> to get a list of
813 parameter names followed by their descriptions.
818 A message stating that the parameters for the policy are unknown if
819 C<parameter_metadata_available()> returns false. Takes an option of
820 what the message should be, which defaults to "Cannot programmatically
821 discover what parameters this policy takes.". The value of this
822 option is interpolated in order to expand the standard escape
823 sequences (C<\n>, C<\t>, etc.).
828 The default severity level of the policy.
833 The current severity level of the policy.
838 The default themes for the policy.
843 The current themes for the policy.
848 The default maximum number of violations per document of the policy.
853 The current maximum number of violations per document of the policy.
861 Jeffrey Ryan Thalhammer <thaljef@cpan.org>
866 Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. All rights reserved.
868 This program is free software; you can redistribute it and/or modify
869 it under the same terms as Perl itself. The full text of this license
870 can be found in the LICENSE file included with this module.
876 # cperl-indent-level: 4
878 # indent-tabs-mode: nil
879 # c-indentation-style: bsd
881 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :