File Coverage

lib/Web/DataService/Vocabulary.pm
Criterion Covered Total %
statement 30 85 35.2
branch 9 52 17.3
condition 1 25 4.0
subroutine 5 7 71.4
pod 0 4 0.0
total 45 173 26.0


line stmt bran cond sub pod time code
1             #
2             # Web::DataService::Vocabulary.pm
3             #
4             # This module provides a role that is used by 'Web::DataService'. It implements
5             # routines for defining and documenting vocabularies.
6             #
7             # Author: Michael McClennen
8              
9 2     2   22 use strict;
  2         4  
  2         96  
10              
11             package Web::DataService::Vocabulary;
12              
13 2     2   14 use Carp 'croak';
  2         6  
  2         103  
14              
15 2     2   12 use Moo::Role;
  2         11  
  2         15  
16              
17             our (%VOCAB_DEF) = (name => 'ignore',
18             title => 'single',
19             doc_node => 'single',
20             use_field_names => 'single',
21             undocumented => 'single',
22             disabled => 'single');
23              
24              
25             # define_vocab ( attrs... )
26             #
27             # Define one or more vocabularies for data service responses. These
28             # vocabularies provide field names for the responses.
29              
30             sub define_vocab {
31              
32 1     1 0 11 my $ds = shift;
33            
34 1         2 my ($last_node);
35            
36             # Now we go through the rest of the arguments. Hashrefs define new
37             # vocabularies, while strings add to the documentation of the vocabulary
38             # whose definition they follow.
39            
40 1         3 foreach my $item (@_)
41             {
42             # A hashref defines a new vocabulary.
43            
44 2 100       8 if ( ref $item eq 'HASH' )
    50          
45             {
46             # Make sure the attributes include 'name'.
47            
48 1         2 my $name = $item->{name};
49            
50 1 50       4 croak "define_vocab: you must include the attribute 'name'" unless $name;
51            
52             # Make sure this vocabulary was not already defined by a previous call,
53             # and set the attributes as specified.
54            
55             croak "define_vocab: '$name' was already defined" if defined $ds->{vocab}{$name}
56 1 50 33     14 and not $ds->{vocab}{$name}{_default};
57            
58             # Create a new record to represent this vocabulary.
59            
60 1         10 my $record = bless { name => $name }, 'Web::DataService::Vocab';
61            
62             # If this entry is for the 'null' vocabulary, then use the
63             # existing record. If this record is to be disabled,
64             # remove it from the vocabulary list.
65            
66 1 50       3 if ( $name eq 'null' )
67             {
68 0         0 $record = $ds->{vocab}{null};
69 0 0       0 shift @{$ds->{vocab_list}} if $item->{disabled};
  0         0  
70             }
71            
72             # Now set the attributes for this vocabulary.
73            
74 1         5 foreach my $k ( keys %$item )
75             {
76 2 50       8 croak "define_vocab: invalid attribute '$k'" unless $VOCAB_DEF{$k};
77            
78 2         4 $record->{$k} = $item->{$k};
79             }
80            
81             # Now install the new vocabulary. But don't add it to the list if
82             # the 'disabled' attribute is set.
83            
84 1         3 $ds->{vocab}{$name} = $record;
85 1 50       4 push @{$ds->{vocab_list}}, $name unless $record->{disabled};
  1         4  
86 1         3 $last_node = $record;
87             }
88            
89             # A scalar is taken to be a documentation string.
90            
91             elsif ( not ref $item )
92             {
93 1         8 $ds->add_node_doc($last_node, $item);
94             }
95            
96             else
97             {
98 0         0 croak "define_vocab: arguments must be hashrefs and strings";
99             }
100             }
101            
102 1 50       5 croak "define_vocab: the arguments must include a hashref of attributes"
103             unless $last_node;
104             }
105              
106              
107             # list_vocabs ( )
108             #
109             # Return the list of names of all the vocabularies that have been defined for
110             # this data service.
111              
112             sub list_vocabs {
113              
114 1     1 0 8 my ($ds) = @_;
115 1         3 return @{$ds->{vocab_list}};
  1         5  
116             }
117              
118              
119             # valid_vocab ( )
120             #
121             # Return a code reference (actually a reference to a closure) that can be used
122             # in a parameter rule to validate a vocaubulary-selecting parameter. All
123             # non-disabled vocabularies are included.
124              
125             sub valid_vocab {
126            
127 0     0 0   my ($ds) = @_;
128            
129             # The ENUM_VALUE subroutine is defined by HTTP::Validate.pm.
130            
131 0           return HTTP::Validate::ENUM_VALUE(@{$ds->{vocab_list}});
  0            
132             }
133              
134              
135             # document_vocabs ( path, options )
136             #
137             # Return a string containing POD documentation of the response vocabularies
138             # that are allowed for the specified path. If the option 'all' is true, then
139             # document all of the vocabularies enabled for this data service regardless of
140             # whether they are actually allowed for that path.
141             #
142             # If the option 'extended' is true, then include the text description of each
143             # vocabulary.
144              
145             sub document_vocabs {
146              
147 0     0 0   my ($ds, $path, $options) = @_;
148            
149 0   0       $options ||= {};
150 0   0       $path ||= '/';
151            
152             # Go through the list of defined vocabularies in order, filtering out
153             # those which are not allowed for this path. The reason for doing it this
154             # way is so that the vocabularies will always be listed in the order
155             # defined, instead of the arbitrary hash order.
156            
157 0           my @vocabs;
158            
159 0 0         if ( $path eq '/' )
160             {
161 0           @vocabs = grep { ! $ds->{vocab}{$_}{undocumented} } @{$ds->{vocab_list}};
  0            
  0            
162             }
163            
164             else
165             {
166 0           my $allowed = $ds->node_attr($path, 'allow_vocab');
167            
168 0 0         return '' unless ref $allowed eq 'HASH';
169            
170 0 0         @vocabs = grep { $allowed->{$_} && ! $ds->{vocab}{$_}{undocumented} } @{$ds->{vocab_list}};
  0            
  0            
171 0 0         return '' unless @vocabs;
172             }
173            
174             # Figure out the default formats for each vocabulary.
175            
176 0           my %default_for;
177            
178 0           foreach my $format ( @{$ds->{format_list}} )
  0            
179             {
180 0   0       my $default_vocab = $ds->{format}{$format}{default_vocab} // $ds->{vocab_list}[0];
181 0 0         push @{$default_for{$default_vocab}}, "C<$format>" if $default_vocab;
  0            
182             }
183            
184             # Go through the list of defined vocabularies in order,
185            
186 0           my @paths = grep { $ds->{vocab}{$_}{doc_node} } @vocabs;
  0            
187            
188 0 0 0       my $ext_header = $options->{extended} || ! @paths ? " | Description" : '';
189 0 0         my $doc_header = @paths ? " | Documentation" : '';
190            
191 0           my $doc = "=for wds_table_header Vocabulary* | Name | Default for $doc_header $ext_header\n\n";
192 0           $doc .= "=over\n\n";
193            
194 0 0         if ( $options->{valid} )
195             {
196 0           $doc = "=for wds_table_no_header Value* | Description\n\n";
197 0           $doc .= "=over\n\n";
198             }
199            
200             VOCABULARY:
201 0           foreach my $name (@vocabs)
202             {
203 0           my $frec = $ds->{vocab}{$name};
204 0   0       my $title = $frec->{title} || $frec->{name};
205 0 0         my $def_list = $default_for{$name} ? join(', ', @{$default_for{$name}}) : '';
  0            
206 0 0         my $doc_link = $ds->node_link($frec->{doc_node}) if $frec->{doc_node};
207            
208 0 0         next VOCABULARY if $frec->{undocumented};
209            
210 0 0         if ( $options->{valid} )
211             {
212 0           $doc .= "=item C<$frec->{name}>\n\n";
213 0 0         $doc .= "$frec->{doc_string}\n\n" if $frec->{doc_string};
214 0           next;
215             }
216            
217 0           $doc .= "=item $title | C<$frec->{name}> | $def_list";
218 0 0 0       $doc .= " | $doc_link" if $doc_link && @paths && $options->{extended};
      0        
219 0           $doc .= "\n\n";
220            
221 0 0 0       if ( $options->{extended} || ! @paths )
    0          
222             {
223 0 0         $doc .= "$frec->{doc_string}\n\n" if $frec->{doc_string};
224             }
225            
226             elsif ( $doc_link )
227             {
228 0           $doc .= "$doc_link\n\n";
229             }
230             }
231            
232 0           $doc .= "=back";
233            
234 0           return $doc;
235             }
236              
237              
238             1;