File Coverage

lib/Config/Grammar/Dynamic.pm
Criterion Covered Total %
statement 254 310 81.9
branch 103 146 70.5
condition 18 33 54.5
subroutine 13 15 86.6
pod 0 2 0.0
total 388 506 76.6


line stmt bran cond sub pod time code
1             package Config::Grammar::Dynamic;
2 2     2   10495 use strict;
  2         2  
  2         47  
3 2     2   603 use Config::Grammar;
  2         3  
  2         57  
4 2     2   11 use base qw(Config::Grammar);
  2         2  
  2         4662  
5              
6             $Config::Grammar::Dynamic::VERSION = $Config::Grammar::VERSION;
7              
8             sub _deepcopy {
9             # this handles circular references on consecutive levels,
10             # but breaks if there are any levels in between
11             # the makepod() and maketmpl() methods have the same limitation
12 411     411   265 my $what = shift;
13 411 100       744 return $what unless ref $what;
14 206         220 for (ref $what) {
15 206 50       301 /^ARRAY$/ and return [ map { $_ eq $what ? $_ : _deepcopy($_) } @$what ];
  106 100       154  
16 153 100       334 /^HASH$/ and return { map { $_ => $what->{$_} eq $what ?
17 293 50       491 $what->{$_} : _deepcopy($what->{$_}) } keys %$what };
18 52 50       151 /^CODE$/ and return $what; # we don't need to copy the subs
19 0 0       0 /^Regexp$/ and return $what; # neither Regexp objects
20             }
21 0         0 die "Cannot _deepcopy reference type @{[ref $what]}";
  0         0  
22             }
23              
24             sub _next_level($$$)
25             {
26 7     7   5 my $self = shift;
27 7         5 my $name = shift;
28              
29             # section name
30 7 100       13 if (defined $self->{section}) {
31 5         8 $self->{section} .= "/$name";
32             }
33             else {
34 2         3 $self->{section} = $name;
35             }
36              
37             # grammar context
38 7         16 my $s = $self->_search_section($name);
39 7 50       12 return 0 unless defined $s;
40 7 50       11 if (not defined $self->{grammar}{$s}) {
41 0         0 $self->_make_error("Config::Grammar internal error (no grammar for $s)");
42 0         0 return 0;
43             }
44 7         6 push @{$self->{grammar_stack}}, $self->{grammar};
  7         10  
45 7 100       15 if ($s =~ m|^/(.*)/$|) {
46             # for sections specified by a regexp, we create
47             # a new branch with a deep copy of the section
48             # grammar so that any _dyn sub further below will edit
49             # just this branch
50              
51 1         2 $self->{grammar}{$name} = _deepcopy($self->{grammar}{$s});
52              
53             # put it at the head of the section list
54 1   50     3 $self->{grammar}{_sections} ||= [];
55 1         1 unshift @{$self->{grammar}{_sections}}, $name;
  1         3  
56             }
57              
58             # support for recursive sections
59             # copy the section syntax to the subsection
60              
61 7 100 100     18 if ($self->{grammar}{_recursive}
62 8         19 and grep { $_ eq $s } @{$self->{grammar}{_recursive}}) {
  5         6  
63 3   50     8 $self->{grammar}{$name}{_sections} ||= [];
64 3   100     7 $self->{grammar}{$name}{_recursive} ||= [];
65 3         5 push @{$self->{grammar}{$name}{_sections}}, $s;
  3         5  
66 3         3 push @{$self->{grammar}{$name}{_recursive}}, $s;
  3         4  
67 3         5 my $grammarcopy = _deepcopy($self->{grammar}{$name});
68 3 50       8 if (exists $self->{grammar}{$name}{$s}) {
69             # there's syntax for a variable by the same name too
70             # make sure we don't lose it
71 0         0 %{$self->{grammar}{$name}{$s}} = ( %$grammarcopy, %{$self->{grammar}{$name}{$s}} );
  0         0  
  0         0  
72             } else {
73 3         5 $self->{grammar}{$name}{$s} = $grammarcopy;
74             }
75             }
76              
77             # this uses the copy created above for regexp sections
78             # and the original for non-regexp sections (where $s == $name)
79 7         10 $self->{grammar} = $self->{grammar}{$name};
80              
81             # support for inherited values
82             # note that we have to do this on the way down
83             # and keep track of which values were inherited
84             # so that we can propagate the values even further
85             # down if needed
86 7         5 my %inherited;
87 7 100       13 if ($self->{grammar}{_inherited}) {
88 5         3 for my $var (@{$self->{grammar}{_inherited}}) {
  5         7  
89 10 100       17 next unless exists $self->{cfg}{$var};
90 6         6 my $value = $self->{cfg}{$var};
91 6 50       8 next unless defined $value;
92 6 50       7 next if ref $value; # it's a section
93 6         11 $inherited{$var} = $value;
94             }
95             }
96              
97             # config context
98 7         9 my $order;
99 7 50       12 if (defined $self->{grammar}{_order}) {
100 0 0       0 if (defined $self->{cfg}{_order_count}) {
101 0         0 $order = ++$self->{cfg}{_order_count};
102             }
103             else {
104 0         0 $order = $self->{cfg}{_order_count} = 0;
105             }
106             }
107              
108 7 50       14 if (defined $self->{cfg}{$name}) {
109 0         0 $self->_make_error('section or variable already exists');
110 0         0 return 0;
111             }
112 7         20 $self->{cfg}{$name} = { %inherited }; # inherit the values
113 7         10 push @{$self->{cfg_stack}}, $self->{cfg};
  7         11  
114 7         7 $self->{cfg} = $self->{cfg}{$name};
115              
116             # keep track of the inherited values here;
117             # we delete it on the way up in _prev_level()
118 7         10 $self->{cfg}{_inherited} = \%inherited;
119              
120             # list of already defined variables on this level
121 7 100       11 if (defined $self->{grammar}{_varlist}) {
122 1         2 $self->{cfg}{_varlist} = [];
123             }
124              
125             # meta data for _mandatory test
126 7         10 $self->{grammar}{_is_section} = 1;
127 7         7 $self->{cfg}{_is_section} = 1;
128              
129             # this uses the copy created above for regexp sections
130             # and the original for non-regexp sections (where $s == $name)
131 7         8 $self->{cfg}{_grammar} = $name;
132              
133 7 50       15 $self->{cfg}{_order} = $order if defined $order;
134              
135             # increase level
136 7         4 $self->{level}++;
137              
138             # if there's a _dyn sub, apply it
139 7 100       13 if (defined $self->{grammar}{_dyn}) {
140 1         1 &{$self->{grammar}{_dyn}}($s, $name, $self->{grammar});
  1         3  
141             }
142              
143 7         33 return 1;
144             }
145              
146             # find variables in old grammar list 'listname'
147             # that aren't in the corresponding list in the new grammar
148             # and list them as a POD document, possibly with a callback
149             # function 'docfunc'
150              
151             sub _findmissing($$$;$) {
152 36     36   23 my $old = shift;
153 36         20 my $new = shift;
154 36         24 my $listname = shift;
155 36         22 my $docfunc = shift;
156              
157 36         17 my @doc;
158 36 100       41 if ($old->{$listname}) {
159 30         20 my %newlist;
160 30 50       37 if ($new->{$listname}) {
161 30         18 @newlist{@{$new->{$listname}}} = undef;
  30         34  
162             }
163 30         18 for my $v (@{$old->{$listname}}) {
  30         31  
164 43 100       63 next if exists $newlist{$v};
165 3 100       5 if ($docfunc) {
166 2         3 push @doc, &$docfunc($old, $v)
167             } else {
168 1         3 push @doc, "=item $v";
169             }
170             }
171             }
172 36         41 return @doc;
173             }
174              
175             # find variables in new grammar list 'listname'
176             # that aren't in the corresponding list in the new grammar
177             #
178             # this is just _findmissing with the arguments swapped
179              
180             sub _findnew($$$;$) {
181 18     18   11 my $old = shift;
182 18         10 my $new = shift;
183 18         15 my $listname = shift;
184 18         7 my $docfunc = shift;
185 18         15 return _findmissing($new, $old, $listname, $docfunc);
186             }
187              
188             # compare two lists for element equality
189              
190             sub _listseq($$);
191             sub _listseq($$) {
192 0     0   0 my ($k, $l) = @_;
193 0         0 my $length = @$k;
194 0 0       0 return 0 unless @$l == $length;
195 0         0 for (my $i=0; $i<$length; $i++) {
196 0 0       0 return 0 unless $k->[$i] eq $l->[$i];
197             }
198 0         0 return 1;
199             }
200              
201             # diff two grammar trees, documenting the differences
202              
203             sub _diffgrammars($$);
204             sub _diffgrammars($$) {
205 9     9   6 my $old = shift;
206 9         6 my $new = shift;
207 9         6 my @doc;
208              
209             my @vdoc;
210 9         10 @vdoc = _findmissing($old, $new, '_vars');
211 9 100       14 push @doc, "The following variables are not valid anymore:", "=over" , @vdoc, "=back"
212             if @vdoc;
213 9         12 @vdoc = _findnew($old, $new, '_vars', \&_describevar);
214 9 100       12 push @doc, "The following new variables are valid:", "=over" , @vdoc, "=back"
215             if @vdoc;
216 9         10 @vdoc = _findmissing($old, $new, '_sections');
217 9 50       10 push @doc, "The following subsections are not valid anymore:", "=over" , @vdoc, "=back"
218             if @vdoc;
219             @vdoc = _findnew($old, $new, '_sections', sub {
220 0     0   0 my ($tree, $sec) = @_;
221 0         0 my @tdoc;
222 0         0 _genpod($tree->{$sec}, 0, \@tdoc);
223 0         0 return @tdoc;
224 9         29 });
225 9 50       24 push @doc, "The following new subsections are defined:", "=over" , @vdoc, "=back"
226             if @vdoc;
227 9         6 for (@{$old->{_sections}}) {
  9         13  
228 4 50       6 next unless exists $new->{$_};
229 4         10 @vdoc = _diffgrammars($old->{$_}, $new->{$_});
230 4 50       5 push @doc, "Syntax changes for subsection B<$_>", "=over", @vdoc, "=back"
231             if @vdoc;
232             }
233 9         11 return @doc;
234             }
235              
236              
237             sub _describevar {
238 18     18   14 my $tree = shift;
239 18         16 my $var = shift;
240             my $mandatory = ( $tree->{_mandatory} and
241 18 50 33     39 grep {$_ eq $var} @{$tree->{_mandatory}} ) ?
242             " I<(mandatory setting)>" : "";
243 18         14 my @doc;
244 18         29 push @doc, "=item B<$var>".$mandatory;
245 18 100       27 push @doc, $tree->{$var}{_doc} if $tree->{$var}{_doc} ;
246             my $inherited = ( $tree->{_inherited} and
247 18   100     28 grep {$_ eq $var} @{$tree->{_inherited}});
248 18 100       22 push @doc, "This variable I its value from the parent section if nothing is specified here."
249             if $inherited;
250             push @doc, "This variable I modifies the grammar based on its value."
251 18 100       26 if $tree->{$var}{_dyn};
252             push @doc, "Default value: $var = $tree->{$var}{_default}"
253 18 100       42 if ($tree->{$var}{_default});
254             push @doc, "Example: $var = $tree->{$var}{_example}"
255 18 50       24 if ($tree->{$var}{_example});
256 18         38 return @doc;
257             }
258              
259             sub _genpod($$$);
260             sub _genpod($$$)
261             {
262 6     6   9 my ($tree, $level, $doc) = @_;
263 6         4 my %dyndoc;
264 6 100       11 if ($tree->{_vars}){
265 5         5 push @{$doc}, "The following variables can be set in this section:";
  5         8  
266 5         5 push @{$doc}, "=over";
  5         3  
267 5         6 foreach my $var (@{$tree->{_vars}}){
  5         10  
268 16         11 push @{$doc}, _describevar($tree, $var);
  16         23  
269             }
270 5         5 push @{$doc}, "=back";
  5         7  
271             }
272              
273 6 50       11 if ($tree->{_text}){
274 0   0     0 push @{$doc}, ($tree->{_text}{_doc} or "Unspecified Text content");
  0         0  
275 0 0       0 if ($tree->{_text}{_example}){
276 0         0 my $ex = $tree->{_text}{_example};
277 0         0 chomp $ex;
278 0         0 $ex = map {" $_"} split /\n/, $ex;
  0         0  
279 0         0 push @{$doc}, "Example:\n\n$ex\n";
  0         0  
280             }
281             }
282              
283 6 50       10 if ($tree->{_table}){
284 0         0 push @{$doc}, ($tree->{_table}{_doc} or
285 0   0     0 "This section can contain a table ".
286             "with the following structure:" );
287 0         0 push @{$doc}, "=over";
  0         0  
288 0         0 for (my $i=0;$i < $tree->{_table}{_columns}; $i++){
289 0         0 push @{$doc}, "=item column $i";
  0         0  
290 0         0 push @{$doc}, ($tree->{_table}{$i}{_doc} or
291 0   0     0 "Unspecific Content");
292 0         0 push @{$doc}, "Example: $tree->{_table}{$i}{_example}"
293             if ($tree->{_table}{$i}{_example})
294 0 0       0 }
295 0         0 push @{$doc}, "=back";
  0         0  
296             }
297 6 100       8 if ($tree->{_sections}){
298 4 100       9 if ($level > 0) {
299 2         2 push @{$doc}, "The following sections are valid on level $level:";
  2         5  
300 2         2 push @{$doc}, "=over";
  2         3  
301             }
302 4         3 foreach my $section (@{$tree->{_sections}}){
  4         6  
303             my $mandatory = ( $tree->{_mandatory} and
304 4 50 33     14 grep {$_ eq $section} @{$tree->{_mandatory}} ) ?
305             " I<(mandatory section)>" : "";
306 4 100       4 push @{$doc}, ($level > 0) ?
  4         36  
307             "=item B<".("+" x $level)."$section>$mandatory" :
308             "=head2 *** $section ***$mandatory";
309 4 50       12 if ($tree eq $tree->{$section}) {
310 0         0 push @{$doc}, "This subsection has the same syntax as its parent.";
  0         0  
311 0         0 next;
312             }
313 0         0 push @{$doc}, ($tree->{$section}{_doc})
314 4 50       7 if $tree->{$section}{_doc};
315 1         1 push @{$doc}, "The grammar of this section is I modified based on its name."
316 4 100       10 if $tree->{$section}{_dyn};
317 4 100 66     7 if ($tree->{_recursive} and
318 1         8 grep {$_ eq $section} @{$tree->{_recursive}}) {
  1         2  
319 1         2 push @{$doc}, "This section is I: it can contain subsection(s) with the same syntax.";
  1         2  
320             }
321 4         38 _genpod ($tree->{$section},$level+1,$doc);
322 4 100 66     14 next unless $tree->{$section}{_dyn} and $tree->{$section}{_dyndoc};
323 1         1 push @{$doc}, "Dynamical grammar changes for example instances of this section:";
  1         1  
324 1         2 push @{$doc}, "=over";
  1         1  
325 1         4 for my $name (sort keys %{$tree->{$section}{_dyndoc}}) {
  1         6  
326 3         6 my $newtree = _deepcopy($tree->{$section});
327 3         5 push @{$doc}, "=item B<$name>: $tree->{$section}{_dyndoc}{$name}";
  3         7  
328 3         3 &{$tree->{$section}{_dyn}}($section, $name, $newtree);
  3         7  
329 3         36 my @tdoc = _diffgrammars($tree->{$section}, $newtree);
330 3 100       5 if (@tdoc) {
331 1         0 push @{$doc}, @tdoc;
  1         2  
332             } else {
333 2         2 push @{$doc}, "No changes that can be automatically described.";
  2         6  
334             }
335 3         3 push @{$doc}, "(End of dynamical grammar changes for example instance C<$name>.)";
  3         10  
336             }
337 1         2 push @{$doc}, "=back";
  1         1  
338 1         1 push @{$doc}, "(End of dynamical grammar changes for example instances of section C<$section>.)";
  1         3  
339             }
340 4 100       6 push @{$doc}, "=back" if $level > 0
  2         3  
341             }
342 6 100       14 if ($tree->{_vars}) {
343 5         17 for my $var (@{$tree->{_vars}}) {
  5         9  
344 16 100 66     32 next unless $tree->{$var}{_dyn} and $tree->{$var}{_dyndoc};
345 1         1 push @{$doc}, "Dynamical grammar changes for example values of variable C<$var>:";
  1         2  
346 1         1 push @{$doc}, "=over";
  1         2  
347 1         1 for my $val (sort keys %{$tree->{$var}{_dyndoc}}) {
  1         4  
348 2         9 my $newtree = _deepcopy($tree);
349 2         3 push @{$doc}, "=item B<$val>: $tree->{$var}{_dyndoc}{$val}";
  2         6  
350 2         3 &{$tree->{$var}{_dyn}}($var, $val, $newtree);
  2         5  
351 2         14 my @tdoc = _diffgrammars($tree, $newtree);
352 2 100       3 if (@tdoc) {
353 1         2 push @{$doc}, @tdoc;
  1         1  
354             } else {
355 1         1 push @{$doc}, "No changes that can be automatically described.";
  1         2  
356             }
357 2         2 push @{$doc}, "(End of dynamical grammar changes for variable C<$var> example value C<$val>.)";
  2         13  
358             }
359 1         1 push @{$doc}, "=back";
  1         2  
360 1         1 push @{$doc}, "(End of dynamical grammar changes for example values of variable C<$var>.)";
  1         3  
361             }
362             }
363             };
364              
365             sub makepod($) {
366 2     2 0 120 my $self = shift;
367 2         12 my $tree = $self->{grammar};
368 2         2 my @doc;
369 2         9 _genpod($tree,0,\@doc);
370 2         26 return join("\n\n", @doc)."\n";
371             }
372              
373              
374             sub _set_variable($$$)
375             {
376 14     14   11 my $self = shift;
377 14         13 my $key = shift;
378 14         12 my $value = shift;
379            
380 14         24 my $gn = $self->_search_variable($key);
381 14 100       24 defined $gn or return 0;
382              
383 13         10 my $varlistref;
384 13 100       38 if (defined $self->{grammar}{_varlist}) {
385 3         6 $varlistref = $self->{cfg}{_varlist};
386             }
387              
388 13 100       23 if (defined $self->{grammar}{$gn}) {
389 12         10 my $g = $self->{grammar}{$gn};
390              
391             # check regular expression
392 12 50       25 if (defined $g->{_re}) {
393 0 0       0 $value =~ /^$g->{_re}$/ or do {
394 0 0       0 if (defined $g->{_re_error}) {
395 0         0 $self->_make_error($g->{_re_error});
396             }
397             else {
398 0         0 $self->_make_error("syntax error in value of '$key'");
399             }
400 0         0 return 0;
401             }
402             }
403 12 100       18 if (defined $g->{_sub}){
404 5         3 my $error = &{$g->{_sub}}($value, $varlistref);
  5         10  
405 5 50       42 if (defined $error){
406 0         0 $self->_make_error($error);
407 0         0 return 0;
408             }
409             }
410             # if there's a _dyn sub, apply it
411 12 100       20 if (defined $g->{_dyn}) {
412 2         2 &{$g->{_dyn}}($key, $value, $self->{grammar});
  2         3  
413             }
414             }
415 13         29 $self->{cfg}{$key} = $value;
416 13 100       19 push @{$varlistref}, $key if ref $varlistref;
  3         4  
417              
418 13         26 return 1;
419             }
420              
421              
422             sub parse($$)
423             {
424 3     3 0 169 my $self = shift;
425 3         4 my $file = shift;
426              
427 3         7 $self->{cfg} = {};
428 3         21 $self->{level} = 0;
429 3         5 $self->{cfg_stack} = [];
430 3         5 $self->{grammar_stack} = [];
431 3         3 $self->{file_stack} = [];
432 3         4 $self->{line_stack} = [];
433              
434             # we work with a copy of the grammar so the _dyn subs may change it
435 3         7 local $self->{grammar} = _deepcopy($self->{grammar});
436              
437 3 100       20 $self->_parse_file($file) or return undef;
438              
439 2 50       6 $self->_goto_level(0, undef) or return undef;
440              
441             # fill in the top level values from _default keywords
442 2         4 $self->_fill_defaults;
443              
444             $self->_check_mandatory($self->{grammar}, $self->{cfg}, undef)
445 2 50       14 or return undef;
446              
447 2         30 return $self->{cfg};
448              
449             }
450              
451             =head1 NAME
452              
453             Config::Grammar::Dynamic - A grammar-based, user-friendly config parser
454              
455             =head1 DESCRIPTION
456              
457             Config::Grammar::Dynamic is like Config::Grammar but with some additional
458             features useful for building configuration grammars that are dynamic, i.e.
459             where the syntax changes according to configuration entries in the same file.
460              
461             The following keys can be additionally specified in the grammar when using this
462             module:
463              
464             =head2 Special Section Keys
465              
466             =over 12
467              
468             =item _dyn
469              
470             A subroutine reference (function pointer) that will be called when
471             a new section of this syntax is encountered. The subroutine will get
472             three arguments: the syntax of the section name (string or regexp), the
473             actual name encountered (this will be the same as the first argument for
474             non-regexp sections) and a reference to the grammar tree of the section.
475             This subroutine can then modify the grammar tree dynamically.
476              
477             =item _dyndoc
478              
479             A hash reference that lists interesting names for the section that
480             should be documented. The keys of the hash are the names and the
481             values in the hash are strings that can contain an explanation
482             for the name. The _dyn() subroutine is then called for each of
483             these names and the differences of the resulting grammar and
484             the original one are documented. This module can currently document
485             differences in the _vars list, listing new variables and removed
486             ones, and differences in the _sections list, listing the
487             new and removed sections.
488              
489             =item _recursive
490              
491             Array containing the list of those sub-sections that are I, ie.
492             that can contain a new sub-section with the same syntax as themselves.
493              
494             The same effect can be accomplished with circular references in the
495             grammar tree or a suitable B<_dyn> section subroutine (see below},
496             so this facility is included just for convenience.
497              
498             =back
499              
500             =head2 Special Variable Keys
501              
502             =over 12
503              
504             =item _dyn
505              
506             A subroutine reference (function pointer) that will be called when the
507             variable is assigned some value in the config file. The subroutine will
508             get three arguments: the name of the variable, the value assigned and
509             a reference to the grammar tree of this section. This subroutine can
510             then modify the grammar tree dynamically.
511              
512             Note that no _dyn() call is made for default and inherited values of
513             the variable.
514              
515             =item _dyndoc
516              
517             A hash reference that lists interesting values for the variable that
518             should be documented. The keys of the hash are the values and the
519             values in the hash are strings that can contain an explanation
520             for the value. The _dyn() subroutine is then called for each of
521             these values and the differences of the resulting grammar and
522             the original one are documented. This module can currently document
523             differences in the _vars list, listing new variables and removed
524             ones, and differences in the _sections list, listing the
525             new and removed sections.
526              
527             =back
528              
529             =head1 COPYRIGHT
530              
531             Copyright (c) 2000-2005 by ETH Zurich. All rights reserved.
532             Copyright (c) 2007 by David Schweikert. All rights reserved.
533              
534             =head1 LICENSE
535              
536             This program is free software; you can redistribute it and/or modify it
537             under the same terms as Perl itself.
538              
539             =head1 AUTHORS
540              
541             David Schweikert,
542             Tobias Oetiker,
543             Niko Tyni
544              
545             =cut
546              
547             # Emacs Configuration
548             #
549             # Local Variables:
550             # mode: cperl
551             # eval: (cperl-set-style "PerlStyle")
552             # mode: flyspell
553             # mode: flyspell-prog
554             # End:
555             #
556             # vi: sw=4