File Coverage

lib/Config/AST/Node/Section.pm
Criterion Covered Total %
statement 49 74 66.2
branch 11 16 68.7
condition 0 2 0.0
subroutine 13 17 76.4
pod 10 11 90.9
total 83 120 69.1


line stmt bran cond sub pod time code
1             # This file is part of Config::AST -*- perl -*-
2             # Copyright (C) 2017-2019 Sergey Poznyakoff
3             #
4             # Config::AST is free software; you can redistribute it and/or modify
5             # it under the terms of the GNU General Public License as published by
6             # the Free Software Foundation; either version 3, or (at your option)
7             # any later version.
8             #
9             # Config::AST is distributed in the hope that it will be useful,
10             # but WITHOUT ANY WARRANTY; without even the implied warranty of
11             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12             # GNU General Public License for more details.
13             #
14             # You should have received a copy of the GNU General Public License
15             # along with Config::AST. If not, see .
16              
17             package Config::AST::Node::Section;
18 19     19   125 use parent 'Config::AST::Node';
  19         34  
  19         96  
19 19     19   1169 use strict;
  19         31  
  19         418  
20 19     19   85 use warnings;
  19         28  
  19         424  
21 19     19   86 use Carp;
  19         42  
  19         1134  
22 19     19   7246 use Config::AST::Node::Null;
  19         44  
  19         14277  
23              
24             =head1 NAME
25              
26             Config::AST::Node::Section - Configuration section node.
27              
28             =head1 DESCRIPTION
29              
30             Nodes of this class represent configuration sections in the AST.
31              
32             =head1 METHODS
33            
34             =head2 new(ROOT, ARG => VAL, ...)
35              
36             Creates new section object. I is the root object of the tree or the
37             B object. The I VAL> pairs are passed to
38             the parent class constructor (see B).
39              
40             =cut
41              
42             sub new {
43 69     69 1 1239 my $class = shift;
44 69 50       200 my $root = shift or croak "mandatory parameter missing";
45 69         230 local %_ = @_;
46 69         316 my $self = $class->SUPER::new(%_);
47 69         204 $self->{_subtree} = {};
48 69 100       442 if ($root->isa('Config::AST')) {
49 48         150 $root = $root->root;
50             }
51 69         147 $self->{_root} = $root;
52 69         220 return $self;
53             }
54              
55 70     70 1 198 sub is_leaf { 0 }
56 108     108 1 292 sub is_section { 1 }
57              
58 347     347 0 673 sub root { shift->{_root} }
59              
60             =head2 $t = $node->subtree
61              
62             Returns tree containing all subordinate nodes of this node.
63              
64             =head2 $t = $node->subtree($key)
65              
66             Returns the subnode at I<$key> or B if there is no such subnode.
67              
68             =head2 $t = $node->subtree($key => $value)
69              
70             Creates new subnode with the given I<$key> and I<$value>. Returns the
71             created node.
72              
73             =cut
74              
75             sub subtree {
76 451     451 1 594 my $self = shift;
77 451 100       779 if (my $key = shift) {
78 327         518 $key = $self->root->mangle_key($key);
79 327 100       684 if (my $val = shift) {
80 104         242 $self->{_subtree}{$key} = $val;
81             }
82 327         1102 return $self->{_subtree}{$key};
83             }
84 124         446 return $self->{_subtree};
85             }
86              
87             =head2 @a = $node->keys;
88              
89             Returns a list of names of all subordinate statements in this section.
90              
91             =cut
92              
93             sub keys {
94 59     59 1 99 my $self = shift;
95 59         82 return keys %{$self->{_subtree}};
  59         348  
96             }
97              
98             =head2 $bool = $node->has_key($str)
99              
100             Returns true if statement with name B<$str> is present in the section
101             described by B<$node>.
102              
103             =cut
104              
105             sub has_key {
106 30     30 1 62 my ($self, $key) = @_;
107 30         59 return $self->subtree($key);
108             }
109              
110             =head2 $node->delete($name)
111              
112             Deletes the node with name B<$name>. Returns the removed node, or C
113             if not found.
114            
115             =cut
116              
117             sub delete {
118 0     0 1 0 my ($self, $key) = @_;
119 0         0 delete $self->{_subtree}{$key};
120             }
121              
122             =head2 $node->merge($other)
123              
124             Merges the section B<$other> (a B) to B<$node>.
125            
126             =cut
127              
128             sub merge {
129 1     1 1 9 my ($self, $other) = @_;
130 1         2 while (my ($k, $v) = each %{$other->subtree}) {
  3         80  
131 2 50       5 if (my $old = $self->subtree($k)) {
132 2 50       7 if ($old->is_section) {
    100          
133 0         0 $old->merge($v);
134             } elsif (ref($old->value) eq 'ARRAY') {
135 1         2 push @{$old->value}, $v->value;
  1         2  
136 1         4 $old->locus->union($v->locus);
137             } else {
138 1         4 $old->value($v->value);
139             }
140             } else {
141 0         0 $self->subtree($k => $old->clone);
142             }
143 2         40 $self->locus->union($v->locus);
144             }
145             }
146              
147             =head2 $h = $cfg->as_hash
148              
149             =head2 $h = $cfg->as_hash($map)
150              
151             Returns parse tree converted to a hash reference. If B<$map> is supplied,
152             it must be a reference to a function. For each I<$key>/I<$value>
153             pair, this function will be called as:
154              
155             ($newkey, $newvalue) = &{$map}($what, $key, $value)
156              
157             where B<$what> is C
or C, depending on the type of the
158             hash entry being processed. Upon successful return, B<$newvalue> will be
159             inserted in the hash slot for the key B<$newkey>.
160              
161             If B<$what> is C
, B<$value> is always a reference to an empty
162             hash (since the parse tree is traversed in pre-order fashion). In that
163             case, the B<$map> function is supposed to do whatever initialization that
164             is necessary for the new subtree and return as B<$newvalue> either B<$value>
165             itself, or a reference to a hash available inside the B<$value>. For
166             example:
167              
168             sub map {
169             my ($what, $name, $val) = @_;
170             if ($name eq 'section') {
171             $val->{section} = {};
172             $val = $val->{section};
173             }
174             ($name, $val);
175             }
176            
177             =cut
178              
179             sub as_hash {
180 0     0 1   my $self = shift;
181 0   0 0     my $map = shift // sub { shift; @_ };
  0            
  0            
182 0           my $hroot = {};
183 0           my @ar;
184            
185 0           push @ar, [ '', $self, $hroot ];
186 0           while (my $elt = shift @ar) {
187 0 0         if ($elt->[1]->is_section) {
188 0           my $hr0 = {};
189 0           my ($name, $hr) = &{$map}('section', $elt->[0], $hr0);
  0            
190 0           $elt->[2]{$name} = $hr0;
191 0           while (my ($kw, $val) = each %{$elt->[1]->subtree}) {
  0            
192 0           push @ar, [ $kw, $val, $hr ];
193             }
194             } else {
195 0           my ($name, $value) = &{$map}('value', $elt->[0], scalar($elt->[1]->value));
  0            
196 0           $elt->[2]{$name} = $value;
197             }
198             }
199 0           return $hroot->{''};
200             }
201              
202             =head2 $s = $node->as_string
203              
204             Returns the string "(section)".
205              
206             =cut
207              
208 0     0 1   sub as_string { '(section)' }
209              
210             =head1 SEE ALSO
211              
212             L,
213             L.
214              
215             =cut
216              
217             1;