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

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyParameter.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;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13 use Readonly;
  14
  15 use base 'Exporter';
  16
  17 Readonly::Array our @EXPORT_OK => qw{ $NO_DESCRIPTION_AVAILABLE };
  18
  19 use String::Format qw{ stringf };
  20
  21 use Perl::Critic::Exception::Fatal::PolicyDefinition
  22     qw{ throw_policy_definition };
  23 use Perl::Critic::PolicyParameter::Behavior;
  24 use Perl::Critic::PolicyParameter::Behavior::Boolean;
  25 use Perl::Critic::PolicyParameter::Behavior::Enumeration;
  26 use Perl::Critic::PolicyParameter::Behavior::Integer;
  27 use Perl::Critic::PolicyParameter::Behavior::String;
  28 use Perl::Critic::PolicyParameter::Behavior::StringList;
  29
  30 use Perl::Critic::Utils qw{ :characters &interpolate };
  31 use Perl::Critic::Utils::DataConversion qw{ &defined_or_empty };
  32
  33 our $VERSION = '1.088';
  34
  35 Readonly::Scalar our $NO_DESCRIPTION_AVAILABLE => 'No description available.';
  36
  37 #-----------------------------------------------------------------------------
  38
  39 # Grrr... one of the OO limitations of Perl: you can't put references to
  40 # subclases in a superclass (well, not nicely).  This map and method belong
  41 # in Behavior.pm.
  42 Readonly::Hash my %BEHAVIORS =>
  43     (
  44         'boolean'     => Perl::Critic::PolicyParameter::Behavior::Boolean->new(),
  45         'enumeration' => Perl::Critic::PolicyParameter::Behavior::Enumeration->new(),
  46         'integer'     => Perl::Critic::PolicyParameter::Behavior::Integer->new(),
  47         'string'      => Perl::Critic::PolicyParameter::Behavior::String->new(),
  48         'string list' => Perl::Critic::PolicyParameter::Behavior::StringList->new(),
  49     );
  50
  51 sub _get_behavior_for_name {
  52     my $behavior_name = shift;
  53
  54     my $behavior = $BEHAVIORS{$behavior_name}
  55         or throw_policy_definition qq{There's no "$behavior_name" behavior.};
  56
  57     return $behavior;
  58 }
  59
  60 #-----------------------------------------------------------------------------
  61
  62 sub new {
  63     my ($class, $specification) = @_;
  64     my $self = bless {}, $class;
  65
  66     defined $specification
  67         or throw_policy_definition
  68             'Attempt to create a ', __PACKAGE__, ' without a specification.';
  69
  70     my $behavior_specification;
  71
  72     my $specification_type = ref $specification;
  73     if ( not $specification_type ) {
  74         $self->{_name} = $specification;
  75
  76         $behavior_specification = {};
  77     } else {
  78         $specification_type eq 'HASH'
  79             or throw_policy_definition
  80                 'Attempt to create a ',
  81                 __PACKAGE__,
  82                 " with a $specification_type as a specification.",
  83                 ;
  84
  85         defined $specification->{name}
  86             or throw_policy_definition
  87                 'Attempt to create a ', __PACKAGE__, ' without a name.';
  88         $self->{_name} = $specification->{name};
  89
  90         $behavior_specification = $specification;
  91     }
  92
  93     $self->_initialize_from_behavior($behavior_specification);
  94     $self->_finish_standard_initialization($behavior_specification);
  95
  96     return $self;
  97 }
  98
  99 # See if the specification includes a Behavior name, and if so, let the
 100 # Behavior with that name plug in its implementations of parser, etc.
 101 sub _initialize_from_behavior {
 102     my ($self, $specification) = @_;
 103
 104     my $behavior_name = $specification->{behavior};
 105     my $behavior;
 106     if ($behavior_name) {
 107         $behavior = _get_behavior_for_name($behavior_name);
 108     } else {
 109         $behavior = _get_behavior_for_name('string');
 110     }
 111
 112     $self->{_behavior} = $behavior;
 113     $self->{_behavior_values} = {};
 114
 115     $behavior->initialize_parameter($self, $specification);
 116
 117     return;
 118 }
 119
 120 # Grab the rest of the values out of the specification, including overrides
 121 # of what the Behavior specified.
 122 sub _finish_standard_initialization {
 123     my ($self, $specification) = @_;
 124
 125     my $description =
 126         $specification->{description} || $NO_DESCRIPTION_AVAILABLE;
 127     $self->_set_description($description);
 128     $self->_set_default_string($specification->{default_string});
 129
 130     $self->_set_parser($specification->{parser});
 131
 132     return;
 133 }
 134
 135 #-----------------------------------------------------------------------------
 136
 137 sub get_name {
 138     my $self = shift;
 139
 140     return $self->{_name};
 141 }
 142
 143 #-----------------------------------------------------------------------------
 144
 145 sub get_description {
 146     my $self = shift;
 147
 148     return $self->{_description};
 149 }
 150
 151 sub _set_description {
 152     my ($self, $new_value) = @_;
 153
 154     return if not defined $new_value;
 155     $self->{_description} = $new_value;
 156
 157     return;
 158 }
 159
 160 sub _get_description_with_trailing_period {
 161     my $self = shift;
 162
 163     my $description = $self->get_description();
 164     if ($description) {
 165         if ( $PERIOD ne substr $description, ( length $description ) - 1 ) {
 166             $description .= $PERIOD;
 167         }
 168     } else {
 169         $description = $EMPTY;
 170     }
 171
 172     return $description;
 173 }
 174
 175 #-----------------------------------------------------------------------------
 176
 177 sub get_default_string {
 178     my $self = shift;
 179
 180     return $self->{_default_string};
 181 }
 182
 183 sub _set_default_string {
 184     my ($self, $new_value) = @_;
 185
 186     return if not defined $new_value;
 187     $self->{_default_string} = $new_value;
 188
 189     return;
 190 }
 191
 192 #-----------------------------------------------------------------------------
 193
 194 sub _get_behavior {
 195     my $self = shift;
 196
 197     return $self->{_behavior};
 198 }
 199
 200 sub _get_behavior_values {
 201     my $self = shift;
 202
 203     return $self->{_behavior_values};
 204 }
 205
 206 #-----------------------------------------------------------------------------
 207
 208 sub _get_parser {
 209     my $self = shift;
 210
 211     return $self->{_parser};
 212 }
 213
 214 sub _set_parser {
 215     my ($self, $new_value) = @_;
 216
 217     return if not defined $new_value;
 218     $self->{_parser} = $new_value;
 219
 220     return;
 221 }
 222
 223 #-----------------------------------------------------------------------------
 224
 225 sub parse_and_validate_config_value {
 226     my ($self, $policy, $config) = @_;
 227
 228     my $config_string = $config->{$self->get_name()};
 229
 230     my $parser = $self->_get_parser();
 231     if ($parser) {
 232         $parser->($policy, $self, $config_string);
 233     }
 234
 235     return;
 236 }
 237
 238 #-----------------------------------------------------------------------------
 239
 240 sub generate_full_description {
 241     my ($self) = @_;
 242
 243     return $self->_get_behavior()->generate_parameter_description($self);
 244 }
 245
 246 #-----------------------------------------------------------------------------
 247
 248 sub _generate_full_description {
 249     my ($self, $prefix) = @_;
 250
 251     my $description = $self->generate_full_description();
 252
 253     if (not $description) {
 254         return $EMPTY;
 255     }
 256
 257     if ($prefix) {
 258         $description =~ s/ ^ /$prefix/xmsg;
 259     }
 260
 261     return $description;
 262 }
 263
 264 #-----------------------------------------------------------------------------
 265
 266 sub to_formatted_string {
 267     my ($self, $format) = @_;
 268
 269     my %specification = (
 270         n => sub { $self->get_name() },
 271         d => sub { defined_or_empty( $self->get_description() ) },
 272         D => sub { defined_or_empty( $self->get_default_string() ) },
 273         f => sub { $self->_generate_full_description(@_) },
 274     );
 275
 276     return stringf( interpolate($format), %specification );
 277 }
 278
 279 #-----------------------------------------------------------------------------
 280
 281 1;
 282
 283 __END__
 284
 285 #-----------------------------------------------------------------------------
 286
 287 =pod
 288
 289 =for stopwords parsable
 290
 291 =head1 NAME
 292
 293 Perl::Critic::PolicyParameter - Metadata about a parameter for a Policy.
 294
 295
 296 =head1 DESCRIPTION
 297
 298 A provider of validation and parsing of parameter values and metadata
 299 about the parameter.
 300
 301
 302 =head1 METHODS
 303
 304 =over
 305
 306 =item C<get_name()>
 307
 308 Return the name of the parameter.  This is the key that will be looked
 309 for in the F<.perlcriticrc>.
 310
 311
 312 =item C<get_description()>
 313
 314 Return an explanation of the significance of the parameter, as
 315 provided by the developer of the policy.
 316
 317
 318 =item C<get_default_string()>
 319
 320 Return a representation of the default value of this parameter as it
 321 would appear if it was specified in a F<.perlcriticrc> file.
 322
 323
 324 =item C<parse_and_validate_config_value( $parser, $config )>
 325
 326 Extract the configuration value for this parameter from the overall
 327 configuration and initialize the policy based upon it.
 328
 329
 330 =item C<generate_full_description()>
 331
 332 Produce a more complete explanation of the significance of this
 333 parameter than the value returned by C<get_description()>.
 334
 335 If no description can be derived, returns the empty string.
 336
 337 Note that the result may contain multiple lines.
 338
 339
 340 =item C<to_formatted_string( $format )>
 341
 342 Generate a string representation of this parameter, based upon the
 343 format.
 344
 345 The format is a combination of literal and escape characters similar
 346 to the way C<sprintf> works.  If you want to know the specific
 347 formatting capabilities, look at L<String::Format>. Valid escape
 348 characters are:
 349
 350 =over
 351
 352 =item C<%n>
 353
 354 The name of the parameter.
 355
 356 =item C<%d>
 357
 358 The description, as supplied by the programmer.
 359
 360 =item C<%D>
 361
 362 The default value, in a parsable form.
 363
 364 =item C<%f>
 365
 366 The full description, which is an extension of the value returned by
 367 C<%d>.  Takes a parameter of a prefix for the beginning of each line.
 368
 369
 370 =back
 371
 372
 373 =back
 374
 375
 376 =head1 SEE ALSO
 377
 378 L<Perl::Critic::DEVELOPER/"MAKING YOUR POLICY CONFIGURABLE">
 379
 380
 381 =head1 AUTHOR
 382
 383 Elliot Shank <perl@galumph.com>
 384
 385 =head1 COPYRIGHT
 386
 387 Copyright (c) 2006-2008 Elliot Shank.  All rights reserved.
 388
 389 This program is free software; you can redistribute it and/or modify
 390 it under the same terms as Perl itself.  The full text of this license
 391 can be found in the LICENSE file included with this module.
 392
 393 =cut
 394
 395 # Local Variables:
 396 #   mode: cperl
 397 #   cperl-indent-level: 4
 398 #   fill-column: 78
 399 #   indent-tabs-mode: nil
 400 #   c-indentation-style: bsd
 401 # End:
 402 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :