File Coverage

blib/lib/Perl/ToPerl6/ProfilePrototype.pm
Criterion Covered Total %
statement 120 120 100.0
branch 5 6 83.3
condition 2 2 100.0
subroutine 16 16 100.0
pod 2 2 100.0
total 145 146 99.3


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