File Coverage

lib/Config/HAProxy/Node/Section.pm
Criterion Covered Total %
statement 44 78 56.4
branch 7 18 38.8
condition 0 3 0.0
subroutine 10 14 71.4
pod 8 9 88.8
total 69 122 56.5


line stmt bran cond sub pod time code
1             package Config::HAProxy::Node::Section;
2 3     3   979 use strict;
  3         6  
  3         68  
3 3     3   16 use warnings;
  3         4  
  3         62  
4 3     3   12 use parent 'Config::HAProxy::Node';
  3         4  
  3         18  
5 3     3   105 use Carp;
  3         6  
  3         2461  
6              
7             =head1 NAME
8              
9             Config::HAProxy::Node::Section - HAProxy configuration section
10              
11             =head1 DESCRIPTION
12              
13             Objects of this class represent a C
in the HAProxy configuration file.
14             A section is a statement that can contain sub-statements. The following
15             statements form sections: B, B, B, and B.
16              
17             =cut
18              
19             sub new {
20 16     16 0 23 my $class = shift;
21 16         52 my $self = $class->SUPER::new(@_);
22 16         43 $self->{_tree} = [];
23 16         28 return $self;
24             }
25              
26             =head1 ATTRIBUTES
27              
28             =head2 is_section
29              
30             Always true.
31              
32             =cut
33              
34 36     36 1 65 sub is_section { 1 }
35              
36             =head1 METHODS
37              
38             =head2 kw
39              
40             Returns the configuration keyword.
41              
42             =head2 argv
43              
44             Returns the list of arguments to the configuration keyword.
45              
46             =head2 arg
47              
48             $s = $node->arg($n)
49              
50             Returns the B<$n>th argument.
51              
52             =head2 orig
53              
54             Returns original line as it appeared in the configuration file.
55              
56             =head2 locus
57              
58             Returns the location of this statement in the configuration file (the
59             B object).
60              
61             =head2 append_node
62              
63             $section->append_node(@nodes);
64              
65             Takes a list of objects of B derived classes as
66             arguments. Adds these objects after the last node in the subtree in this
67             section.
68              
69             =cut
70              
71             sub append_node {
72 34     34 1 40 my $self = shift;
73 34         34 my $n = @{$self->{_tree}};
  34         40  
74 34         55 push @{$self->{_tree}},
75             map {
76 34         34 $_->parent($self);
  34         101  
77 34         79 $_->index($n++);
78 34         159 $_
79             } @_;
80             }
81              
82             =head2 append_node_nonempty
83              
84             $section->append_node_nonempty(@nodes);
85              
86             Same as B, but adds new nodes after the last non-empty
87             node in the subtree.
88              
89             =cut
90              
91             sub append_node_nonempty {
92 0     0 1 0 my $self = shift;
93 0         0 my $n = $#{$self->{_tree}};
  0         0  
94 0   0     0 while ($n >= 0 && $self->{_tree}[$n]->is_empty) {
95 0         0 $n--;
96             }
97 0         0 $self->insert_node($n+1, @_);
98             }
99              
100             =head2 insert_node
101              
102             $section->insert_node($idx, @nodes);
103              
104             Inserts B<@nodes> after subnode in position B<$idx> (0-based).
105              
106             =cut
107              
108             sub insert_node {
109 0     0 1 0 my $self = shift;
110 0         0 my $n = shift;
111 0         0 my $i = $n;
112 0         0 splice @{$self->{_tree}}, $n, 0,
113             map {
114 0         0 $_->parent($self);
  0         0  
115 0         0 $_->index($i++);
116 0         0 $_
117             } @_;
118 0         0 for (; $i < @{$self->{_tree}}; $i++) {
  0         0  
119 0         0 $self->{_tree}[$i]->index($i);
120             }
121             }
122              
123             =head2 delete_node
124              
125             $section->delete_node($i);
126              
127             Deletes B<$i>th subnode from the B<$section>.
128              
129             =cut
130              
131             sub delete_node {
132 0     0 1 0 my ($self, $n) = @_;
133 0         0 splice @{$self->{_tree}}, $n, 1;
  0         0  
134 0         0 for (; $n < @{$self->{_tree}}; $n++) {
  0         0  
135 0         0 $self->{_tree}[$n]->index($n);
136             }
137 0         0 $self->root->mark_dirty;
138             }
139              
140             =head2 tree
141              
142             @nodes = $section->tree;
143              
144             Returns subnodes as a list of B derived objects.
145              
146             $node = $section->tree($i);
147              
148             Returns B<$i>th subnode from the B<$section>.
149              
150             =cut
151              
152             sub tree {
153 22     22 1 29 my ($self, $n) = @_;
154 22 50       32 if ($n) {
155 0 0       0 return undef if $n >= @{$self->{_tree}};
  0         0  
156 0         0 return $self->{_tree}[$n];
157             }
158 22         20 return @{shift->{_tree}}
  22         68  
159             };
160              
161             =head2 ends_in_empty
162              
163             $bool = $section->ends_in_empty
164              
165             Returns true if the last node in the list of sub-nodes in B<$section> is
166             an empty node.
167              
168             =cut
169              
170             sub ends_in_empty {
171 0     0 1 0 my $self = shift;
172 0         0 while ($self->is_section) {
173 0         0 $self = $self->tree(-1);
174             }
175 0         0 return $self->is_empty;
176             }
177            
178             my %match = (
179             name => {
180             wantarg => 1,
181             matcher => sub {
182             my ($node, $value) = @_;
183             return $node->kw && $node->kw eq $value;
184             }
185             },
186             arg => {
187             wantarg => 1,
188             matcher => sub {
189             my ($node, $value) = @_;
190             my $arg = $node->arg($value->{n});
191             return $arg && $arg eq $value->{v};
192             }
193             },
194             section => {
195             matcher => sub {
196             my $node = shift;
197             return $node->is_section;
198             }
199             },
200             statement => {
201             matcher => sub {
202             my $node = shift;
203             return $node->is_statement;
204             }
205             },
206             comment => {
207             matcher => sub {
208             my $node = shift;
209             return $node->is_comment;
210             }
211             }
212             );
213            
214             =head2 select
215              
216             @nodes = $section->select(%cond);
217              
218             Returns nodes from B<$section> that match conditions in B<%cond>. Valid
219             conditions are:
220              
221             =over 4
222              
223             =item B> I<$s>
224              
225             Node matches if its keyword (B) equals I<$s>.
226              
227             =item B> B<{ n =E> I<$n>, B =E I<$s> B<}>
228              
229             Node mathches if its I<$n>th argument equals I<$s>.
230              
231             =item B
> I<$bool>
232              
233             Node matches if it is (or is not, if I<$bool> is false) a section.
234              
235             =item B> I<$bool>
236              
237             Node matches if it is (not) a simple statement.
238              
239             =item B> I<$bool>
240              
241             Node matches if it is (not) a comment.
242              
243             =back
244              
245             Multiple conditions are checked in the order of their appearance in the
246             argument list and are joined by the short-circuit logical C.
247              
248             For example, to return all B statements:
249              
250             @fe = $section->select(name => 'frontend');
251              
252             To return the frontend named C:
253              
254             ($fe) = $section->select( name => 'frontend',
255             arg => { n => 0, v => 'in' } );
256              
257             =cut
258              
259             sub select {
260 2     2 1 3 my $self = shift;
261 2         2 my @prog;
262 2         5 while (my $p = shift) {
263 3 50       6 my $arg = shift or croak "missing argument";
264 3 50       7 my $m = $match{$p} or croak "unknown matcher: $p";
265 3 50       6 if ($m->{wantarg}) {
    0          
266 3         9 push @prog, [ $m->{matcher}, $arg ];
267             } elsif ($arg) {
268 0         0 push @prog, $m->{matcher};
269             }
270             }
271 2         6 grep { _test_node($_, @prog) } $self->tree;
  10         14  
272             }
273              
274             sub _test_node {
275 10     10   11 my $node = shift;
276 10         11 foreach my $f (@_) {
277 12 50       23 if (ref($f) eq 'ARRAY') {
278 12 100       15 return 0 unless &{$f->[0]}($node, $f->[1]);
  12         14  
279             } else {
280 0 0       0 return 0 unless &{$f}($node);
  0         0  
281             }
282             }
283 3         6 return 1;
284             }
285              
286             =head1 SEE ALSO
287              
288             B, B, B.
289              
290             =cut
291              
292             1;
293              
294