File Coverage

lib/Web/DataService/Set.pm
Criterion Covered Total %
statement 47 94 50.0
branch 12 46 26.0
condition 2 15 13.3
subroutine 7 13 53.8
pod 0 8 0.0
total 68 176 38.6


line stmt bran cond sub pod time code
1             #
2             # Web::DataService::Set
3             #
4             # This module provides a role that is used by 'Web::DataService'. It implements
5             # routines for defining and documenting output formats.
6             #
7             # Author: Michael McClennen
8              
9 2     2   15 use strict;
  2         5  
  2         85  
10              
11             package Web::DataService::Set;
12              
13 2     2   12 use Carp 'croak';
  2         5  
  2         99  
14 2     2   16 use Scalar::Util 'reftype';
  2         4  
  2         92  
15              
16 2     2   13 use Moo::Role;
  2         5  
  2         11  
17              
18              
19             our (%SET_DEF) = (value => 'single',
20             maps_to => 'single',
21             disabled => 'single',
22             undocumented => 'single',
23             doc_string => 'single');
24              
25             # define_map ( name, specification... )
26             #
27             # Define a set of values, with optional value map and documentation. Such
28             # sets can be used to define and document acceptable parameter values,
29             # document data values, and many other uses.
30             #
31             # The names of sets must be unique within a single data service.
32              
33             sub define_set {
34              
35 1     1 0 17 my $self = shift;
36 1         3 my $name = shift;
37            
38             # Make sure the name is unique.
39            
40 1 50       4 croak "define_set: the first argument must be a valid name"
41             unless $self->valid_name($name);
42            
43             croak "define_set: '$name' was already defined at $self->{valueset}{$name}{defined_at}"
44 1 50       11 if ref $self->{valueset}{$name};
45            
46             # Create a new set object.
47            
48 1         5 my ($package, $filename, $line) = caller;
49            
50 1         19 my $vs = { name => $name,
51             defined_at => "line $line of $filename",
52             value => {},
53             value_list => [] };
54            
55 1         7 bless $vs, 'Web::DataService::Set';
56            
57 1         9 $self->{set}{$name} = $vs;
58            
59             # Then process the records and documentation strings one by one. Throw an
60             # exception if we find an invalid record.
61            
62 1         3 my $doc_node;
63             my @doc_lines;
64            
65 1         3 foreach my $item (@_)
66             {
67             # A scalar is interpreted as a documentation string.
68            
69 4 100       12 unless ( ref $item )
70             {
71 2 50       9 $self->add_doc($vs, $item) if defined $item;
72 2         5 next;
73             }
74            
75             # Any item that is not a record or a scalar is an error.
76            
77 2 50 33     13 unless ( ref $item && reftype $item eq 'HASH' )
78             {
79 0         0 croak "define_set: arguments must be records (hash refs) and documentation strings";
80             }
81            
82             # Add the record to the documentation list.
83            
84 2         8 $self->add_doc($vs, $item);
85            
86             # Check for invalid attributes.
87            
88 2         13 foreach my $k ( keys %$item )
89             {
90             croak "define_set: unknown attribute '$k'"
91 4 50       11 unless defined $SET_DEF{$k};
92             }
93            
94             # Check that each reord contains an actual value, and that these
95             # values do not repeat.
96            
97 2         5 my $value = $item->{value};
98            
99 2 50 33     9 croak "define_set: you must specify a nonempty 'value' key in each record"
100             unless defined $value && $value ne '';
101            
102             croak "define_set: value '$value' cannot be defined twice"
103 2 50       6 if exists $vs->{value}{$value};
104            
105             # Add the value to the various lists it belongs to, and to the hash
106             # containing all defined values.
107            
108 2 50       11 push @{$vs->{value_list}}, $value unless $item->{disabled};
  2         6  
109 2         5 $vs->{value}{$value} = $item;
110             }
111            
112             # Finish the documentation for this object.
113            
114 1         4 $self->process_doc($vs);
115            
116 1         3 my $a = 1; # we can stop here when debugging
117             }
118              
119              
120             # set_defined ( name )
121             #
122             # Return true if the given argument is the name of a set that has been defined
123             # for the current data service, false otherweise.
124              
125             sub set_defined {
126            
127 0     0 0 0 my ($self, $name) = @_;
128            
129 0         0 return ref $self->{set}{$name} eq 'Web::DataService::Set';
130             }
131              
132              
133             # valid_set ( name )
134             #
135             # Return a reference to a validator routine (actualy a closure) which will
136             # accept the list of values defined for the specified set. If the given name
137             # does not correspond to any set, the returned routine will reject any value
138             # it is given.
139              
140             sub valid_set {
141              
142 0     0 0 0 my ($self, $set_name) = @_;
143            
144 0         0 my $vs = $self->{set}{$set_name};
145            
146 0 0       0 unless ( ref $vs eq 'Web::DataService::Set' )
147             {
148 0 0 0     0 unless ( $Web::DataService::QUIET || $ENV{WDS_QUIET} )
149             {
150 0         0 warn "WARNING: unknown set '$set_name'";
151             }
152 0         0 return \&bad_set_validator;
153             }
154            
155             # If there is at least one enabled value for this set, return the
156             # appropriate closure.
157            
158 0 0 0     0 if ( ref $vs->{value_list} eq 'ARRAY' && @{$vs->{value_list}} )
  0         0  
159             {
160 0         0 return HTTP::Validate::ENUM_VALUE( @{$vs->{value_list}} );
  0         0  
161             }
162            
163             # Otherwise, return a reference to a routine which will always return an
164             # error.
165            
166 0         0 return \&bad_set_validator;
167             }
168              
169              
170             sub bad_set_validator {
171              
172 0     0 0 0 return { error => "No valid values have been defined for {param}." };
173             }
174              
175              
176             # document_set ( set_name )
177             #
178             # Return a string in Pod format documenting the values that were assigned to
179             # this set.
180              
181             sub document_set {
182              
183 0     0 0 0 my ($self, $set_name) = @_;
184            
185             # Look up a set object using the given name. If none could be found,
186             # return an explanatory message.
187            
188 0         0 my $vs = $self->{set}{$set_name};
189            
190 0 0       0 return "=over\n\n=item I\n\n=back"
191             unless ref $vs eq 'Web::DataService::Set';
192            
193 0         0 my @values; @values = grep { ! $vs->{value}{$_}{undocumented} } @{$vs->{value_list}}
  0         0  
  0         0  
194 0 0       0 if ref $vs->{value_list} eq 'ARRAY';
195            
196 0 0       0 return "=over\n\n=item I\n\n=back"
197             unless @values;
198            
199             # Now return the documentation in Pod format.
200            
201 0         0 my $doc = "=over\n\n";
202            
203 0         0 foreach my $name ( @values )
204             {
205 0         0 my $rec = $vs->{value}{$name};
206            
207 0         0 $doc .= "=item $rec->{value}\n\n";
208 0 0 0     0 $doc .= "$rec->{doc_string}\n\n" if defined $rec->{doc_string} && $rec->{doc_string} ne '';
209             }
210            
211 0         0 $doc .= "=back";
212            
213 0         0 return $doc;
214             }
215              
216              
217             # list_set_values ( set_name )
218             #
219             # Return a list of the documented values defined for the specified set.
220              
221             sub list_set_values {
222            
223 1     1 0 6 my ($ds, $name) = @_;
224            
225 1 50       3 return unless defined $name;
226            
227 1         3 my $set = $ds->{set}{$name};
228            
229 1 50       5 return unless ref $set eq 'Web::DataService::Set';
230 1         2 return grep { ! $set->{value}{$_}{undocumented} } @{$set->{value_list}};
  2         8  
  1         3  
231             }
232              
233              
234             # set_values ( set_name )
235             #
236             # Return a list of records representing the values defined for the specified
237             # set.
238              
239             sub set_values {
240            
241 0     0 0   my ($ds, $name) = @_;
242            
243 0           my $set = $ds->{set}{$name};
244            
245 0 0         croak "set_values: set '$name' not found\n"
246             unless ref $set eq 'Web::DataService::Set';
247            
248 0           my @list;
249            
250 0           foreach my $v ( @{$set->{value_list}} )
  0            
251             {
252 0 0         next if $set->{value}{$v}{undocumented};
253            
254 0           my $sr = $set->{value}{$v};
255 0           my $r = { value => $sr->{value} };
256 0 0         $r->{maps_to} = $sr->{maps_to} if defined $sr->{maps_to};
257 0 0         $r->{doc_string} = $sr->{doc_string} if defined $sr->{doc_string};
258            
259 0           push @list, $r;
260             }
261            
262 0           return @list;
263             }
264              
265              
266             # map_value ( set_name, value )
267             #
268             # If the given value is a member of the named set, then return the 'maps_to'
269             # value if any was defined. Return undef otherwise.
270              
271             sub map_value {
272            
273 2     2   2881 no warnings 'uninitialized';
  2         20  
  2         260  
274            
275 0     0 0   my ($ds, $name, $value) = @_;
276            
277 0           my $set = $ds->{set}{$name};
278            
279 0 0         croak "set_values: set '$name' not found\n"
280             unless ref $set eq 'Web::DataService::Set';
281            
282 0           return $set->{value}{$value}{maps_to};
283             }
284              
285             1;