vcs.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.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::PolicyParameter::Behavior::Enumeration;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13
  14 use Perl::Critic::Exception::Fatal::PolicyDefinition
  15     qw{ &throw_policy_definition };
  16 use Perl::Critic::Utils qw{ :characters &words_from_string &hashify };
  17
  18 use base qw{ Perl::Critic::PolicyParameter::Behavior };
  19
  20 our $VERSION = '1.088';
  21
  22 #-----------------------------------------------------------------------------
  23
  24 sub initialize_parameter {
  25     my ($self, $parameter, $specification) = @_;
  26
  27     my $valid_values = $specification->{enumeration_values}
  28         or throw_policy_definition
  29             'No enumeration_values given for '
  30                 . $parameter->get_name()
  31                 . $PERIOD;
  32     ref $valid_values eq 'ARRAY'
  33         or throw_policy_definition
  34             'The value given for enumeration_values for '
  35                 . $parameter->get_name()
  36                 . ' is not an array reference.';
  37     scalar @{$valid_values} > 1
  38         or throw_policy_definition
  39             'There were not at least two valid values given for'
  40                 . ' enumeration_values for '
  41                 . $parameter->get_name()
  42                 . $PERIOD;
  43
  44     # Unfortunately, this has to be a reference, rather than a regular hash,
  45     # due to a problem in Devel::Cycle
  46     # (http://rt.cpan.org/Ticket/Display.html?id=25360) which causes
  47     # t/92_memory_leaks.t to fall over.
  48     my $value_lookup = { hashify( @{$valid_values} ) };
  49     $parameter->_get_behavior_values()->{enumeration_values} = $value_lookup;
  50
  51     my $allow_multiple_values =
  52         $specification->{enumeration_allow_multiple_values};
  53
  54     if ($allow_multiple_values) {
  55         $parameter->_set_parser(
  56             sub {
  57                 # Normally bad thing, obscuring a variable in a outer scope
  58                 # with a variable with the same name is being done here in
  59                 # order to remain consistent with the parser function interface.
  60                 my ($policy, $parameter, $config_string) = @_;
  61
  62                 my @potential_values;
  63                 my $value_string = $parameter->get_default_string();
  64
  65                 if (defined $config_string) {
  66                     $value_string = $config_string;
  67                 }
  68
  69                 if ( defined $value_string ) {
  70                     @potential_values = words_from_string($value_string);
  71
  72                     my @bad_values =
  73                         grep { not exists $value_lookup->{$_} } @potential_values;
  74                     if (@bad_values) {
  75                         $policy->throw_parameter_value_exception(
  76                             $parameter->get_name(),
  77                             $value_string,
  78                             undef,
  79                             q{contains invalid values: }
  80                                 . join (q{, }, @bad_values)
  81                                 . q{. Allowed values are: }
  82                                 . join (q{, }, sort keys %{$value_lookup})
  83                                 . qq{.\n},
  84                         );
  85                     }
  86                 }
  87
  88                 my %actual_values = hashify(@potential_values);
  89
  90                 $policy->__set_parameter_value($parameter, \%actual_values);
  91
  92                 return;
  93             }
  94         );
  95     } else {
  96         $parameter->_set_parser(
  97             sub {
  98                 # Normally bad thing, obscuring a variable in a outer scope
  99                 # with a variable with the same name is being done here in
 100                 # order to remain consistent with the parser function interface.
 101                 my ($policy, $parameter, $config_string) = @_;
 102
 103                 my $value_string = $parameter->get_default_string();
 104
 105                 if (defined $config_string) {
 106                     $value_string = $config_string;
 107                 }
 108
 109                 if (
 110                         defined $value_string
 111                     and $EMPTY ne $value_string
 112                     and not defined $value_lookup->{$value_string}
 113                 ) {
 114                     $policy->throw_parameter_value_exception(
 115                         $parameter->get_name(),
 116                         $value_string,
 117                         undef,
 118                         q{is not one of the allowed values: }
 119                             . join (q{, }, sort keys %{$value_lookup})
 120                             . qq{.\n},
 121                     );
 122                 }
 123
 124                 $policy->__set_parameter_value($parameter, $value_string);
 125
 126                 return;
 127             }
 128         );
 129     }
 130
 131     return;
 132 }
 133
 134 #-----------------------------------------------------------------------------
 135
 136 sub generate_parameter_description {
 137     my ($self, $parameter) = @_;
 138
 139     my $description = $parameter->_get_description_with_trailing_period();
 140     if ( $description ) {
 141         $description .= qq{\n};
 142     }
 143
 144     my %values = %{$parameter->_get_behavior_values()->{enumeration_values}};
 145     return
 146         $description
 147         . 'Valid values: '
 148         . join (', ', sort keys %values)
 149         . $PERIOD;
 150 }
 151
 152 #-----------------------------------------------------------------------------
 153
 154 1;
 155
 156 __END__
 157
 158 #-----------------------------------------------------------------------------
 159
 160 =pod
 161
 162 =for stopwords
 163
 164 =head1 NAME
 165
 166 Perl::Critic::PolicyParameter::Behavior::Enumeration - Actions appropriate for an enumerated value.
 167
 168
 169 =head1 DESCRIPTION
 170
 171 Provides a standard set of functionality for an enumerated
 172 L<Perl::Critic::PolicyParameter> so that the developer of a policy
 173 does not have to provide it her/himself.
 174
 175 NOTE: Do not instantiate this class.  Use the singleton instance held
 176 onto by L<Perl::Critic::PolicyParameter>.
 177
 178
 179 =head1 METHODS
 180
 181 =over
 182
 183 =item C<initialize_parameter( $parameter, $specification )>
 184
 185 Plug in the functionality this behavior provides into the parameter,
 186 based upon the configuration provided by the specification.
 187
 188 This behavior looks for two configuration items:
 189
 190 =over
 191
 192 =item enumeration_values
 193
 194 Mandatory.  The set of valid values for the parameter, as an array
 195 reference.
 196
 197 =item enumeration_allow_multiple_values
 198
 199 Optional, defaults to false.  Should the parameter support a single
 200 value or accept multiple?
 201
 202 =back
 203
 204 =item C<generate_parameter_description( $parameter )>
 205
 206 Create a description of the parameter, based upon the description on
 207 the parameter itself, but enhancing it with information from this
 208 behavior.
 209
 210 In this specific case, the universe of values is added at the end.
 211
 212 =back
 213
 214
 215 =head1 AUTHOR
 216
 217 Elliot Shank <perl@galumph.com>
 218
 219 =head1 COPYRIGHT
 220
 221 Copyright (c) 2006-2008 Elliot Shank.  All rights reserved.
 222
 223 This program is free software; you can redistribute it and/or modify
 224 it under the same terms as Perl itself.  The full text of this license
 225 can be found in the LICENSE file included with this module.
 226
 227 =cut
 228
 229 # Local Variables:
 230 #   mode: cperl
 231 #   cperl-indent-level: 4
 232 #   fill-column: 78
 233 #   indent-tabs-mode: nil
 234 #   c-indentation-style: bsd
 235 # End:
 236 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :