File Coverage

blib/lib/Perl/ToPerl6/TransformerParameter/Behavior/Enumeration.pm
Criterion Covered Total %
statement 54 61 88.5
branch 18 20 90.0
condition 5 6 83.3
subroutine 9 10 90.0
pod 2 2 100.0
total 88 99 88.8


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