File Coverage

blib/lib/Perl/Critic/PolicyParameter.pm
Criterion Covered Total %
statement 123 128 96.0
branch 18 28 64.2
condition 3 9 33.3
subroutine 35 36 97.2
pod 6 7 85.7
total 185 208 88.9


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