File Coverage

blib/lib/Perl/Critic/ProfilePrototype.pm
Criterion Covered Total %
statement 117 117 100.0
branch 3 4 75.0
condition 4 4 100.0
subroutine 16 16 100.0
pod 2 2 100.0
total 142 143 99.3


line stmt bran cond sub pod time code
1             package Perl::Critic::ProfilePrototype;
2              
3 2     2   2136 use 5.010001;
  2         20  
4 2     2   14 use strict;
  2         5  
  2         44  
5 2     2   26 use warnings;
  2         9  
  2         74  
6              
7 2     2   18 use English qw(-no_match_vars);
  2         5  
  2         12  
8              
9 2     2   748 use Perl::Critic::Config qw{};
  2         4  
  2         37  
10 2     2   18 use Perl::Critic::Policy qw{};
  2         13  
  2         53  
11 2     2   15 use Perl::Critic::Utils qw{ :characters };
  2         6  
  2         137  
12 2     2   511 use overload ( q{""} => 'to_string' );
  2         7  
  2         15  
13              
14             our $VERSION = '1.146';
15              
16             #-----------------------------------------------------------------------------
17              
18             sub new {
19 2     2 1 2128 my ($class, %args) = @_;
20 2         8 my $self = bless {}, $class;
21              
22 2   100     11 my $policies = $args{-policies} || [];
23 2         5 $self->{_policies} = [ sort _by_type @{ $policies } ];
  2         37  
24              
25 2   100     13 $self->{_comment_out_parameters} = $args{'-comment-out-parameters'} // 1;
26              
27 2         6 my $configuration = $args{'-config'};
28 2 100       7 if (not $configuration) {
29 1         9 $configuration = Perl::Critic::Config->new(-profile => $EMPTY);
30             }
31 2         7 $self->{_configuration} = $configuration;
32              
33              
34 2         11 return $self;
35             }
36              
37             #-----------------------------------------------------------------------------
38              
39             sub _get_policies {
40 1     1   3 my ($self) = @_;
41              
42 1         5 return $self->{_policies};
43             }
44              
45             sub _comment_out_parameters {
46 2     2   6 my ($self) = @_;
47              
48 2         8 return $self->{_comment_out_parameters};
49             }
50              
51             sub _configuration {
52 1     1   3 my ($self) = @_;
53              
54 1         3 return $self->{_configuration};
55             }
56              
57             #-----------------------------------------------------------------------------
58              
59             sub _line_prefix {
60 2     2   5 my ($self) = @_;
61              
62 2 50       6 return $self->_comment_out_parameters() ? q{# } : $EMPTY;
63             }
64              
65             #-----------------------------------------------------------------------------
66              
67             sub to_string {
68 1     1 1 8 my ($self) = @_;
69              
70 1         4 my $prefix = $self->_line_prefix();
71 1         4 my $configuration = $self->_configuration();
72              
73 1         3 my $prototype = "# Globals\n";
74              
75 1         3 $prototype .= $prefix;
76 1         3 $prototype .= q{severity = };
77 1         5 $prototype .= $configuration->severity();
78 1         9 $prototype .= "\n";
79              
80 1         7 $prototype .= $prefix;
81 1         8 $prototype .= q{force = };
82 1         7 $prototype .= $configuration->force();
83 1         4 $prototype .= "\n";
84              
85 1         2 $prototype .= $prefix;
86 1         3 $prototype .= q{only = };
87 1         4 $prototype .= $configuration->only();
88 1         2 $prototype .= "\n";
89              
90 1         3 $prototype .= $prefix;
91 1         4 $prototype .= q{allow-unsafe = };
92 1         6 $prototype .= $configuration->unsafe_allowed();
93 1         3 $prototype .= "\n";
94              
95 1         3 $prototype .= $prefix;
96 1         3 $prototype .= q{profile-strictness = };
97 1         5 $prototype .= $configuration->profile_strictness();
98 1         3 $prototype .= "\n";
99              
100 1         11 $prototype .= $prefix;
101 1         4 $prototype .= q{color = };
102 1         6 $prototype .= $configuration->color();
103 1         3 $prototype .= "\n";
104              
105 1         3 $prototype .= $prefix;
106 1         3 $prototype .= q{pager = };
107 1         8 $prototype .= $configuration->pager();
108 1         6 $prototype .= "\n";
109              
110 1         2 $prototype .= $prefix;
111 1         2 $prototype .= q{top = };
112 1         5 $prototype .= $configuration->top();
113 1         3 $prototype .= "\n";
114              
115 1         3 $prototype .= $prefix;
116 1         3 $prototype .= q{verbose = };
117 1         5 $prototype .= $configuration->verbose();
118 1         2 $prototype .= "\n";
119              
120 1         3 $prototype .= $prefix;
121 1         2 $prototype .= q{include = };
122 1         3 $prototype .= join $SPACE, $configuration->include();
123 1         3 $prototype .= "\n";
124              
125 1         4 $prototype .= $prefix;
126 1         3 $prototype .= q{exclude = };
127 1         3 $prototype .= join $SPACE, $configuration->exclude();
128 1         3 $prototype .= "\n";
129              
130 1         3 $prototype .= $prefix;
131 1         3 $prototype .= q{single-policy = };
132 1         4 $prototype .= join $SPACE, $configuration->single_policy();
133 1         4 $prototype .= "\n";
134              
135 1         3 $prototype .= $prefix;
136 1         2 $prototype .= q{theme = };
137 1         11 $prototype .= $configuration->theme()->rule();
138 1         4 $prototype .= "\n";
139              
140 1         4 foreach my $item (qw<
141             color-severity-highest
142             color-severity-high
143             color-severity-medium
144             color-severity-low
145             color-severity-lowest
146             >) {
147 5         19 ( my $accessor = $item ) =~ s/ - /_/gmsx;
148 5         8 $prototype .= $prefix;
149 5         12 $prototype .= "$item = ";
150 5         27 $prototype .= $configuration->$accessor;
151 5         15 $prototype .= "\n";
152             }
153              
154 1         7 $prototype .= $prefix;
155 1         8 $prototype .= q{program-extensions = };
156 1         5 $prototype .= join $SPACE, $configuration->program_extensions();
157              
158 1         9 Perl::Critic::Policy::set_format( $self->_proto_format() );
159              
160 1         3 my $policy_prototypes = join qq{\n}, map { "$_" } @{ $self->_get_policies() };
  143         10490  
  1         5  
161 1         1027 $policy_prototypes =~ s/\s+ \z//xms; # Trim trailing whitespace
162 1         79 return $prototype . "\n\n" . $policy_prototypes . "\n";
163             }
164              
165             #-----------------------------------------------------------------------------
166              
167             # About "%{\\n%\\x7b# \\x7df\n${prefix}%n = %D\\n}O" below:
168             #
169             # The %0 format for a policy specifies how to format parameters.
170             # For a parameter %f specifies the full description.
171             #
172             # The problem is that both of these need to take options, but String::Format
173             # doesn't allow nesting of {}. So, to get the option to the %f, the braces
174             # are hex encoded. I.e., assuming that comment_out_parameters is in effect,
175             # the parameter sees:
176             #
177             # \n%{# }f\n# %n = %D\n
178              
179             sub _proto_format {
180 1     1   4 my ($self) = @_;
181              
182 1         4 my $prefix = $self->_line_prefix();
183              
184 1         18 return <<"END_OF_FORMAT";
185             # %a
186             [%p]
187             ${prefix}set_themes = %t
188             ${prefix}add_themes =
189             ${prefix}severity = %s
190             ${prefix}maximum_violations_per_document = %v
191             %{\\n%\\x7b# \\x7df\\n${prefix}%n = %D\\n}O%{${prefix}Cannot programmatically discover what parameters this policy takes.\\n}U
192             END_OF_FORMAT
193              
194             }
195              
196             #-----------------------------------------------------------------------------
197              
198 142     142   343 sub _by_type { return ref $a cmp ref $b }
199              
200             1;
201              
202             __END__
203              
204             =pod
205              
206             =head1 NAME
207              
208             Perl::Critic::ProfilePrototype - Generate an initial Perl::Critic profile.
209              
210              
211             =head1 DESCRIPTION
212              
213             This is a helper class that generates a prototype of a
214             L<Perl::Critic|Perl::Critic> profile (e.g. a F<.perlcriticrc> file.
215             There are no user-serviceable parts here.
216              
217              
218             =head1 INTERFACE SUPPORT
219              
220             This is considered to be a non-public class. Its interface is subject
221             to change without notice.
222              
223              
224             =head1 CONSTRUCTOR
225              
226             =over
227              
228             =item C<< new( -policies => \@POLICY_OBJECTS ) >>
229              
230             Returns a reference to a new C<Perl::Critic::ProfilePrototype> object.
231              
232              
233             =back
234              
235              
236             =head1 METHODS
237              
238             =over
239              
240             =item to_string()
241              
242             Returns a string representation of this C<ProfilePrototype>. See
243             L<"OVERLOADS"> for more information.
244              
245              
246             =back
247              
248              
249             =head1 OVERLOADS
250              
251             When a
252             L<Perl::Critic::ProfilePrototype|Perl::Critic::ProfilePrototype> is
253             evaluated in string context, it produces a multi-line summary of the
254             policy name, default themes, and default severity for each
255             L<Perl::Critic::Policy|Perl::Critic::Policy> object that was given to
256             the constructor of this C<ProfilePrototype>. If the Policy supports
257             an additional parameters, they will also be listed (but
258             commented-out). The format is suitable for use as a F<.perlcriticrc>
259             file.
260              
261              
262             =head1 AUTHOR
263              
264             Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>
265              
266              
267             =head1 COPYRIGHT
268              
269             Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved.
270              
271             This program is free software; you can redistribute it and/or modify
272             it under the same terms as Perl itself. The full text of this license
273             can be found in the LICENSE file included with this module.
274              
275             =cut
276              
277             # Local Variables:
278             # mode: cperl
279             # cperl-indent-level: 4
280             # fill-column: 78
281             # indent-tabs-mode: nil
282             # c-indentation-style: bsd
283             # End:
284             # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :