summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorTobi Oetiker <tobi@oetiker.ch>2007-09-25 14:29:53 +0200
committerTobi Oetiker <tobi@oetiker.ch>2007-09-25 14:29:53 +0200
commit4e23d2b3b310038131e8952aef1150c392b4f448 (patch)
treefea065a8487816643a73ababa82a9f3e5f928b04 /lib
parent7b910a7d34a768f75e03ce357a0e8446e3237677 (diff)
downloadsmokeping-4e23d2b3b310038131e8952aef1150c392b4f448.tar.gz
smokeping-4e23d2b3b310038131e8952aef1150c392b4f448.tar.xz
updated to config grammar 1.10
Diffstat (limited to 'lib')
-rw-r--r--lib/Config/Grammar.pm403
-rw-r--r--lib/Config/Grammar/Dynamic.pm556
-rw-r--r--lib/Smokeping.pm4
-rw-r--r--lib/Smokeping/Config.pm15
4 files changed, 662 insertions, 316 deletions
diff --git a/lib/Config/Grammar.pm b/lib/Config/Grammar.pm
index 835b12b..3291042 100644
--- a/lib/Config/Grammar.pm
+++ b/lib/Config/Grammar.pm
@@ -5,8 +5,7 @@ package Config::Grammar;
use strict;
-use vars qw($VERSION);
-$VERSION = '1.02';
+$Config::Grammar::VERSION = '1.10';
sub new($$)
{
@@ -64,22 +63,6 @@ sub _quotesplit($)
return @items;
}
-sub _deepcopy {
- # this handles circular references on consecutive levels,
- # but breaks if there are any levels in between
- # the makepod() and maketmpl() methods have the same limitation
- my $what = shift;
- return $what unless ref $what;
- for (ref $what) {
- /^ARRAY$/ and return [ map { $_ eq $what ? $_ : _deepcopy($_) } @$what ];
- /^HASH$/ and return { map { $_ => $what->{$_} eq $what ?
- $what->{$_} : _deepcopy($what->{$_}) } keys %$what };
- /^CODE$/ and return $what; # we don't need to copy the subs
- /^Regexp$/ and return $what; # neither Regexp objects
- }
- die "Cannot _deepcopy reference type @{[ref $what]}";
-}
-
sub _check_mandatory($$$$)
{
my $self = shift;
@@ -201,45 +184,11 @@ sub _next_level($$$)
my $s = $self->_search_section($name);
return 0 unless defined $s;
if (not defined $self->{grammar}{$s}) {
- $self->_make_error("Config::Grammar internal error (no grammar for $s)");
+ $self->_make_error("ParseConfig internal error (no grammar for $s)");
return 0;
}
push @{$self->{grammar_stack}}, $self->{grammar};
- if ($s =~ m|^/(.*)/$|) {
- # for sections specified by a regexp, we create
- # a new branch with a deep copy of the section
- # grammar so that any _dyn sub further below will edit
- # just this branch
-
- $self->{grammar}{$name} = _deepcopy($self->{grammar}{$s});
-
- # put it at the head of the section list
- $self->{grammar}{_sections} ||= [];
- unshift @{$self->{grammar}{_sections}}, $name;
- }
-
- # support for recursive sections
- # copy the section syntax to the subsection
-
- if ($self->{grammar}{_recursive}
- and grep { $_ eq $s } @{$self->{grammar}{_recursive}}) {
- $self->{grammar}{$name}{_sections} ||= [];
- $self->{grammar}{$name}{_recursive} ||= [];
- push @{$self->{grammar}{$name}{_sections}}, $s;
- push @{$self->{grammar}{$name}{_recursive}}, $s;
- my $grammarcopy = _deepcopy($self->{grammar}{$name});
- if (exists $self->{grammar}{$name}{$s}) {
- # there's syntax for a variable by the same name too
- # make sure we don't lose it
- %{$self->{grammar}{$name}{$s}} = ( %$grammarcopy, %{$self->{grammar}{$name}{$s}} );
- } else {
- $self->{grammar}{$name}{$s} = $grammarcopy;
- }
- }
-
- # this uses the copy created above for regexp sections
- # and the original for non-regexp sections (where $s == $name)
- $self->{grammar} = $self->{grammar}{$name};
+ $self->{grammar} = $self->{grammar}{$s};
# support for inherited values
# note that we have to do this on the way down
@@ -288,21 +237,12 @@ sub _next_level($$$)
# meta data for _mandatory test
$self->{grammar}{_is_section} = 1;
$self->{cfg}{_is_section} = 1;
-
- # this uses the copy created above for regexp sections
- # and the original for non-regexp sections (where $s == $name)
- $self->{cfg}{_grammar} = $name;
-
+ $self->{cfg}{_grammar} = $s;
$self->{cfg}{_order} = $order if defined $order;
# increase level
$self->{level}++;
- # if there's a _dyn sub, apply it
- if (defined $self->{grammar}{_dyn}) {
- &{$self->{grammar}{_dyn}}($s, $name, $self->{grammar});
- }
-
return 1;
}
@@ -316,7 +256,7 @@ sub _prev_level($)
# section name
if (defined $self->{section}) {
if ($self->{section} =~ /\//) {
- $self->{section} =~ s,/[^/]*$,,;
+ $self->{section} =~ s/\/.*?$//;
}
else {
$self->{section} = undef;
@@ -436,10 +376,6 @@ sub _set_variable($$$)
return 0;
}
}
- # if there's a _dyn sub, apply it
- if (defined $g->{_dyn}) {
- &{$g->{_dyn}}($key, $value, $self->{grammar});
- }
}
$self->{cfg}{$key} = $value;
push @{$varlistref}, $key if ref $varlistref;
@@ -480,10 +416,10 @@ sub _parse_table($$)
if (defined $gc->{_re}) {
$c =~ /^$gc->{_re}$/ or do {
if (defined $gc->{_re_error}) {
- $self->_make_error($gc->{_re_error});
+ $self->_make_error("column ".($n+1).": $gc->{_re_error}");
}
else {
- $self->_make_error("syntax error in column $n");
+ $self->_make_error("syntax error in column ".($n+1));
}
return 0;
};
@@ -579,9 +515,14 @@ sub _parse_line($$$)
my $source = shift;
/^\@include\s+["']?(.*)["']?$/ and do {
+ my $inc = $1;
+ if ( ( $^O eq 'win32' and $inc !~ m|^(?:[a-z]:)?[/\\]|i and $self->{file} =~ m|^(.+)[\\/][^/]+$| ) or
+ ( $inc !~ m|^/| and $self->{file} =~ m|^(.+)/[^/]+$| ) ){
+ $inc = "$1/$inc";
+ }
push @{$self->{file_stack}}, $self->{file};
push @{$self->{line_stack}}, $self->{line};
- $self->_parse_file($1) or return 0;
+ $self->_parse_file($inc) or return 0;
$self->{file} = pop @{$self->{file_stack}};
$self->{line} = pop @{$self->{line_stack}};
return 1;
@@ -657,7 +598,6 @@ sub _parse_file($$)
local *File;
unless ($file) { $self->{'err'} = "no filename given" ;
return undef;};
-
open(File, "$file") or do {
$self->{'err'} = "can't open $file: $!";
return undef;
@@ -691,96 +631,6 @@ sub _parse_file($$)
return 1;
}
-# find variables in old grammar list 'listname'
-# that aren't in the corresponding list in the new grammar
-# and list them as a POD document, possibly with a callback
-# function 'docfunc'
-
-sub _findmissing($$$;$) {
- my $old = shift;
- my $new = shift;
- my $listname = shift;
- my $docfunc = shift;
-
- my @doc;
- if ($old->{$listname}) {
- my %newlist;
- if ($new->{$listname}) {
- @newlist{@{$new->{$listname}}} = undef;
- }
- for my $v (@{$old->{$listname}}) {
- next if exists $newlist{$v};
- if ($docfunc) {
- push @doc, &$docfunc($old, $v)
- } else {
- push @doc, "=item $v";
- }
- }
- }
- return @doc;
-}
-
-# find variables in new grammar list 'listname'
-# that aren't in the corresponding list in the new grammar
-#
-# this is just _findmissing with the arguments swapped
-
-sub _findnew($$$;$) {
- my $old = shift;
- my $new = shift;
- my $listname = shift;
- my $docfunc = shift;
- return _findmissing($new, $old, $listname, $docfunc);
-}
-
-# compare two lists for element equality
-
-sub _listseq($$);
-sub _listseq($$) {
- my ($k, $l) = @_;
- my $length = @$k;
- return 0 unless @$l == $length;
- for (my $i=0; $i<$length; $i++) {
- return 0 unless $k->[$i] eq $l->[$i];
- }
- return 1;
-}
-
-# diff two grammar trees, documenting the differences
-
-sub _diffgrammars($$);
-sub _diffgrammars($$) {
- my $old = shift;
- my $new = shift;
- my @doc;
-
- my @vdoc;
- @vdoc = _findmissing($old, $new, '_vars');
- push @doc, "The following variables are not valid anymore:", "=over" , @vdoc, "=back"
- if @vdoc;
- @vdoc = _findnew($old, $new, '_vars', \&_describevar);
- push @doc, "The following new variables are valid:", "=over" , @vdoc, "=back"
- if @vdoc;
- @vdoc = _findmissing($old, $new, '_sections');
- push @doc, "The following subsections are not valid anymore:", "=over" , @vdoc, "=back"
- if @vdoc;
- @vdoc = _findnew($old, $new, '_sections', sub {
- my ($tree, $sec) = @_;
- my @tdoc;
- _genpod($tree->{$sec}, 0, \@tdoc);
- return @tdoc;
- });
- push @doc, "The following new subsections are defined:", "=over" , @vdoc, "=back"
- if @vdoc;
- for (@{$old->{_sections}}) {
- next unless exists $new->{$_};
- @vdoc = _diffgrammars($old->{$_}, $new->{$_});
- push @doc, "Syntax changes for subsection B<$_>", "=over", @vdoc, "=back"
- if @vdoc;
- }
- return @doc;
-}
-
# describe a variable
sub _describevar {
@@ -796,8 +646,6 @@ sub _describevar {
grep {$_ eq $var} @{$tree->{_inherited}});
push @doc, "This variable I<inherits> its value from the parent section if nothing is specified here."
if $inherited;
- push @doc, "This variable I<dynamically> modifies the grammar based on its value."
- if $tree->{$var}{_dyn};
push @doc, "Default value: $var = $tree->{$var}{_default}"
if ($tree->{$var}{_default});
push @doc, "Example: $var = $tree->{$var}{_example}"
@@ -806,11 +654,9 @@ sub _describevar {
}
sub _genpod($$$);
-sub _genpod($$$){
- my $tree = shift;
- my $level = shift;
- my $doc = shift;
- my %dyndoc;
+sub _genpod($$$)
+{
+ my ($tree, $level, $doc) = @_;
if ($tree->{_vars}){
push @{$doc}, "The following variables can be set in this section:";
push @{$doc}, "=over";
@@ -862,67 +708,24 @@ sub _genpod($$$){
}
push @{$doc}, ($tree->{$section}{_doc})
if $tree->{$section}{_doc};
- push @{$doc}, "The grammar of this section is I<dynamically> modified based on its name."
- if $tree->{$section}{_dyn};
- if ($tree->{_recursive} and
- grep {$_ eq $section} @{$tree->{_recursive}}) {
- push @{$doc}, "This section is I<recursive>: it can contain subsection(s) with the same syntax.";
- }
- _genpod ($tree->{$section},$level+1,$doc);
- next unless $tree->{$section}{_dyn} and $tree->{$section}{_dyndoc};
- push @{$doc}, "Dynamical grammar changes for example instances of this section:";
- push @{$doc}, "=over";
- for my $name (sort keys %{$tree->{$section}{_dyndoc}}) {
- my $newtree = _deepcopy($tree->{$section});
- push @{$doc}, "=item B<$name>: $tree->{$section}{_dyndoc}{$name}";
- &{$tree->{$section}{_dyn}}($section, $name, $newtree);
- my @tdoc = _diffgrammars($tree->{$section}, $newtree);
- if (@tdoc) {
- push @{$doc}, @tdoc;
- } else {
- push @{$doc}, "No changes that can be automatically described.";
- }
- push @{$doc}, "(End of dynamical grammar changes for example instance C<$name>.)";
- }
- push @{$doc}, "=back";
- push @{$doc}, "(End of dynamical grammar changes for example instances of section C<$section>.)";
+ _genpod($tree->{$section},$level+1,$doc);
}
push @{$doc}, "=back" if $level > 0
}
- if ($tree->{_vars}) {
- for my $var (@{$tree->{_vars}}) {
- next unless $tree->{$var}{_dyn} and $tree->{$var}{_dyndoc};
- push @{$doc}, "Dynamical grammar changes for example values of variable C<$var>:";
- push @{$doc}, "=over";
- for my $val (sort keys %{$tree->{$var}{_dyndoc}}) {
- my $newtree = _deepcopy($tree);
- push @{$doc}, "=item B<$val>: $tree->{$var}{_dyndoc}{$val}";
- &{$tree->{$var}{_dyn}}($var, $val, $newtree);
- my @tdoc = _diffgrammars($tree, $newtree);
- if (@tdoc) {
- push @{$doc}, @tdoc;
- } else {
- push @{$doc}, "No changes that can be automatically described.";
- }
- push @{$doc}, "(End of dynamical grammar changes for variable C<$var> example value C<$val>.)";
- }
- push @{$doc}, "=back";
- push @{$doc}, "(End of dynamical grammar changes for example values of variable C<$var>.)";
- }
- }
};
sub makepod($) {
my $self = shift;
my $tree = $self->{grammar};
my @doc;
- _genpod $tree,0,\@doc;
+ _genpod($tree,0,\@doc);
return join("\n\n", @doc)."\n";
}
sub _gentmpl($$$@);
sub _gentmpl($$$@){
my $tree = shift;
+ my $complete = shift;
my $level = shift;
my $doc = shift;
my @start = @_;
@@ -935,12 +738,19 @@ sub _gentmpl($$$@){
if ($tree->{$section}{_example}) {
$secex = " # ( ex. $tree->{$section}{_example} )";
}
- push @{$doc}, $prefix.
- (($level > 0) ? ("+" x $level)."$section" : "*** $section ***").$secex;
+
+ if($complete) {
+ push @{$doc}, $prefix.
+ (($level > 0) ? ("+" x $level)."$section" : "*** $section ***").$secex;
+ } else {
+ my $minsection=$section =~ m|^/| ? "" : $section;
+ push @{$doc},(($level > 0) ? ("+" x $level)."$minsection" : "*** $minsection ***");
+ }
+
my $match;
foreach my $s (@{$tree->{_sections}}){
if ($s =~ m|^/.+/$| and $section =~ /$s/ or $s eq $section) {
- _gentmpl ($tree->{$s},$level+1,$doc,@start)
+ _gentmpl ($tree->{$s},$complete,$level+1,$doc,@start)
unless $tree eq $tree->{$s};
$match = 1;
}
@@ -950,15 +760,21 @@ sub _gentmpl($$$@){
} else {
if ($tree->{_vars}){
foreach my $var (@{$tree->{_vars}}){
- push @{$doc}, "# $var = ".
- ($tree->{$var}{_example} || ' * no example *');
- next unless $tree->{_mandatory} and
- grep {$_ eq $var} @{$tree->{_mandatory}};
- push @{$doc}, "$var=";
+ my $mandatory= ($tree->{_mandatory} and
+ grep {$_ eq $var} @{$tree->{_mandatory}});
+ if($complete) {
+ push @{$doc}, "# $var = ".
+ ($tree->{$var}{_example} || ' * no example *');
+ push @{$doc}, "$var=" if $mandatory;
+ } else {
+ push @{$doc}, ($mandatory?"":"# ")."$var=";
+ next unless $tree->{_mandatory} and
+ grep {$_ eq $var} @{$tree->{_mandatory}};
+ }
}
}
- if ($tree->{_text}){
+ if ($tree->{_text} and $complete){
if ($tree->{_text}{_example}){
my $ex = $tree->{_text}{_example};
chomp $ex;
@@ -966,7 +782,7 @@ sub _gentmpl($$$@){
push @{$doc}, "$ex\n";
}
}
- if ($tree->{_table}){
+ if ($tree->{_table} and $complete){
my $table = "# table\n#";
for (my $i=0;$i < $tree->{_table}{_columns}; $i++){
$table .= ' "'.($tree->{_table}{$i}{_example} || "C$i").'"';
@@ -975,20 +791,28 @@ sub _gentmpl($$$@){
}
if ($tree->{_sections}){
foreach my $section (@{$tree->{_sections}}){
- my $opt = ( $tree->{_mandatory} and
- grep {$_ eq $section} @{$tree->{_mandatory}} ) ?
- "":"\n# optional section\n";
+ my $opt = "";
+ unless( $tree->{_mandatory} and
+ grep {$_ eq $section} @{$tree->{_mandatory}} ) {
+ $opt="\n# optional section\n" if $complete;
+ }
my $prefix = '';
$prefix = "# " unless $tree->{_mandatory} and
grep {$_ eq $section} @{$tree->{_mandatory}};
my $secex ="";
if ($section =~ m|^/.+/$| && $tree->{$section}{_example}) {
- $secex = " # ( ex. $tree->{$section}{_example} )";
+ $secex = " # ( ex. $tree->{$section}{_example} )"
+ if $complete;
}
- push @{$doc}, $prefix.
- (($level > 0) ? ("+" x $level)."$section" : "*** $section ***").
- $secex;
- _gentmpl ($tree->{$section},$level+1,$doc,@start)
+ if($complete) {
+ push @{$doc}, $prefix.
+ (($level > 0) ? ("+" x $level)."$section" : "*** $section ***").
+ $secex;
+ } else {
+ my $minsection=$section =~ m|^/| ? "" : $section;
+ push @{$doc},(($level > 0) ? ("+" x $level)."$minsection" : "*** $minsection ***");
+ }
+ _gentmpl ($tree->{$section},$complete,$level+1,$doc,@start)
unless $tree eq $tree->{$section};
}
}
@@ -1000,7 +824,16 @@ sub maketmpl ($@) {
my @start = @_;
my $tree = $self->{grammar};
my @tmpl;
- _gentmpl $tree,0,\@tmpl,@start;
+ _gentmpl $tree,1,0,\@tmpl,@start;
+ return join("\n", @tmpl)."\n";
+}
+
+sub makemintmpl ($@) {
+ my $self = shift;
+ my @start = @_;
+ my $tree = $self->{grammar};
+ my @tmpl;
+ _gentmpl $tree,0,0,\@tmpl,@start;
return join("\n", @tmpl)."\n";
}
@@ -1016,9 +849,6 @@ sub parse($$)
$self->{file_stack} = [];
$self->{line_stack} = [];
- # we work with a copy of the grammar so the _dyn subs may change it
- local $self->{grammar} = _deepcopy($self->{grammar});
-
$self->_parse_file($file) or return undef;
$self->_goto_level(0, undef) or return undef;
@@ -1049,6 +879,7 @@ Config::Grammar - A grammar-based, user-friendly config parser
my $cfg = $parser->parse('app.cfg') or die "ERROR: $parser->{err}\n";
my $pod = $parser->makepod();
my $ex = $parser->maketmpl('TOP','SubNode');
+ my $minex = $parser->maketmplmin('TOP','SubNode');
=head1 DESCRIPTION
@@ -1064,7 +895,11 @@ documentation of the configuration file format.
The B<maketmpl> method can generate a template configuration file. If
your grammar contains regexp matches, the template will not be all
that helpful as Config::Grammar is not smart enough to give you sensible
-template data based in regular expressions.
+template data based in regular expressions. The related function
+B<maketmplmin> generates a minimal configuration template without
+examples, regexps or comments and thus allows an experienced user to
+fill in the configuration data more efficiently.
+
=head2 Grammar Definition
@@ -1090,15 +925,6 @@ The sub-section can also be a regular expression denoted by the syntax '/re/',
where re is the regular-expression. In case a regular expression is used, a
sub-hash named with the same '/re/' must be included in this hash.
-=item _recursive
-
-Array containing the list of those sub-sections that are I<recursive>, ie.
-that can contain a new sub-section with the same syntax as themselves.
-
-The same effect can be accomplished with circular references in the
-grammar tree or a suitable B<_dyn> section subroutine (see below},
-so this facility is included just for convenience.
-
=item _vars
Array containing the list of variables (assignments) in this section.
@@ -1135,17 +961,6 @@ If defined, a '_order' element will be put in every hash containing the
sections with a number that determines the order in which the sections were
defined.
-=item _varlist
-
-If defined, a '_varlist' element will be put in the config hash of this
-section with a list of the variables defined in the section. This can
-be used to find out the order of the variable assignments.
-
-The '_sub' function (see below) of any variables defined in this section
-will also receive a list of those variables already defined in the
-same section. This can be used to enforce the order of the variables
-during parsing.
-
=item _doc
Describes what this section is about
@@ -1158,27 +973,6 @@ probably only useful for the regexp sections. If the function returns
a defined value it is assumed that the test was not successful and an
error is generated with the returned string as content.
-=item _dyn
-
-A subroutine reference (function pointer) that will be called when
-a new section of this syntax is encountered. The subroutine will get
-three arguments: the syntax of the section name (string or regexp), the
-actual name encountered (this will be the same as the first argument for
-non-regexp sections) and a reference to the grammar tree of the section.
-This subroutine can then modify the grammar tree dynamically.
-
-=item _dyndoc
-
-A hash reference that lists interesting names for the section that
-should be documented. The keys of the hash are the names and the
-values in the hash are strings that can contain an explanation
-for the name. The _dyn() subroutine is then called for each of
-these names and the differences of the resulting grammar and
-the original one are documented. This module can currently document
-differences in the _vars list, listing new variables and removed
-ones, and differences in the _sections list, listing the
-new and removed sections.
-
=back
=head3 Special Variable Keys
@@ -1218,29 +1012,6 @@ Description of the variable.
A one line example for the content of this variable.
-=item _dyn
-
-A subroutine reference (function pointer) that will be called when the
-variable is assigned some value in the config file. The subroutine will
-get three arguments: the name of the variable, the value assigned and
-a reference to the grammar tree of this section. This subroutine can
-then modify the grammar tree dynamically.
-
-Note that no _dyn() call is made for default and inherited values of
-the variable.
-
-=item _dyndoc
-
-A hash reference that lists interesting values for the variable that
-should be documented. The keys of the hash are the values and the
-values in the hash are strings that can contain an explanation
-for the value. The _dyn() subroutine is then called for each of
-these values and the differences of the resulting grammar and
-the original one are documented. This module can currently document
-differences in the _vars list, listing new variables and removed
-ones, and differences in the _sections list, listing the
-new and removed sections.
-
=back
=head3 Special Table Keys
@@ -1310,7 +1081,8 @@ at the beginning and end of lines is trimmed.
'\' at the end of the line marks a continued line on the next line. A single
space will be inserted between the concatenated lines.
-'@include filename' is used to include another file.
+'@include filename' is used to include another file. Include works relative to the
+directory where the parent file is in.
'@define a some value' will replace all occurences of 'a' in the following text
with 'some value'.
@@ -1358,6 +1130,13 @@ The data is interpreted as one or more columns separated by spaces.
=head3 Code
+ use Data::Dumper;
+ use Config::Grammar;
+
+ my $RE_IP = '\d+\.\d+\.\d+\.\d+';
+ my $RE_MAC = '[0-9a-f]{2}(?::[0-9a-f]{2}){5}';
+ my $RE_HOST = '\S+';
+
my $parser = Config::Grammar->new({
_sections => [ 'network', 'hosts' ],
network => {
@@ -1420,7 +1199,7 @@ The data is interpreted as one or more columns separated by spaces.
my $cfg = $parser->parse('test.cfg') or
die "ERROR: $parser->{err}\n";
print Dumper($cfg);
- print $praser->makepod;
+ print $parser->makepod;
=head3 Configuration
@@ -1471,22 +1250,18 @@ The data is interpreted as one or more columns separated by spaces.
=head1 COPYRIGHT
Copyright (c) 2000-2005 by ETH Zurich. All rights reserved.
+Copyright (c) 2007 by David Schweikert. All rights reserved.
=head1 LICENSE
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
-=head1 AUTHOR
-
-David Schweikert E<lt>dws_at_ee.ethz.chE<gt>,
-Tobias Oetiker E<lt>oetiker_at_ee.ethz.chE<gt>,
-Niko Tyni E<lt>ntyni_at_iki.fiE<gt>
-
-=head1 HISTORY
+=head1 AUTHORS
- 2001-05-11 ds Initial Version of ISG::ParseConfig
- 2005-03-08 ds 1.00 Renamed from ISG::ParseConfig to Config::Grammar
+David Schweikert,
+Tobias Oetiker,
+Niko Tyni
=cut
diff --git a/lib/Config/Grammar/Dynamic.pm b/lib/Config/Grammar/Dynamic.pm
new file mode 100644
index 0000000..58de1be
--- /dev/null
+++ b/lib/Config/Grammar/Dynamic.pm
@@ -0,0 +1,556 @@
+package Config::Grammar::Dynamic;
+use strict;
+use Config::Grammar;
+use base qw(Config::Grammar);
+
+$Config::Grammar::Dynamic::VERSION = $Config::Grammar::VERSION;
+
+sub _deepcopy {
+ # this handles circular references on consecutive levels,
+ # but breaks if there are any levels in between
+ # the makepod() and maketmpl() methods have the same limitation
+ my $what = shift;
+ return $what unless ref $what;
+ for (ref $what) {
+ /^ARRAY$/ and return [ map { $_ eq $what ? $_ : _deepcopy($_) } @$what ];
+ /^HASH$/ and return { map { $_ => $what->{$_} eq $what ?
+ $what->{$_} : _deepcopy($what->{$_}) } keys %$what };
+ /^CODE$/ and return $what; # we don't need to copy the subs
+ /^Regexp$/ and return $what; # neither Regexp objects
+ }
+ die "Cannot _deepcopy reference type @{[ref $what]}";
+}
+
+sub _next_level($$$)
+{
+ my $self = shift;
+ my $name = shift;
+
+ # section name
+ if (defined $self->{section}) {
+ $self->{section} .= "/$name";
+ }
+ else {
+ $self->{section} = $name;
+ }
+
+ # grammar context
+ my $s = $self->_search_section($name);
+ return 0 unless defined $s;
+ if (not defined $self->{grammar}{$s}) {
+ $self->_make_error("Config::Grammar internal error (no grammar for $s)");
+ return 0;
+ }
+ push @{$self->{grammar_stack}}, $self->{grammar};
+ if ($s =~ m|^/(.*)/$|) {
+ # for sections specified by a regexp, we create
+ # a new branch with a deep copy of the section
+ # grammar so that any _dyn sub further below will edit
+ # just this branch
+
+ $self->{grammar}{$name} = _deepcopy($self->{grammar}{$s});
+
+ # put it at the head of the section list
+ $self->{grammar}{_sections} ||= [];
+ unshift @{$self->{grammar}{_sections}}, $name;
+ }
+
+ # support for recursive sections
+ # copy the section syntax to the subsection
+
+ if ($self->{grammar}{_recursive}
+ and grep { $_ eq $s } @{$self->{grammar}{_recursive}}) {
+ $self->{grammar}{$name}{_sections} ||= [];
+ $self->{grammar}{$name}{_recursive} ||= [];
+ push @{$self->{grammar}{$name}{_sections}}, $s;
+ push @{$self->{grammar}{$name}{_recursive}}, $s;
+ my $grammarcopy = _deepcopy($self->{grammar}{$name});
+ if (exists $self->{grammar}{$name}{$s}) {
+ # there's syntax for a variable by the same name too
+ # make sure we don't lose it
+ %{$self->{grammar}{$name}{$s}} = ( %$grammarcopy, %{$self->{grammar}{$name}{$s}} );
+ } else {
+ $self->{grammar}{$name}{$s} = $grammarcopy;
+ }
+ }
+
+ # this uses the copy created above for regexp sections
+ # and the original for non-regexp sections (where $s == $name)
+ $self->{grammar} = $self->{grammar}{$name};
+
+ # support for inherited values
+ # note that we have to do this on the way down
+ # and keep track of which values were inherited
+ # so that we can propagate the values even further
+ # down if needed
+ my %inherited;
+ if ($self->{grammar}{_inherited}) {
+ for my $var (@{$self->{grammar}{_inherited}}) {
+ next unless exists $self->{cfg}{$var};
+ my $value = $self->{cfg}{$var};
+ next unless defined $value;
+ next if ref $value; # it's a section
+ $inherited{$var} = $value;
+ }
+ }
+
+ # config context
+ my $order;
+ if (defined $self->{grammar}{_order}) {
+ if (defined $self->{cfg}{_order_count}) {
+ $order = ++$self->{cfg}{_order_count};
+ }
+ else {
+ $order = $self->{cfg}{_order_count} = 0;
+ }
+ }
+
+ if (defined $self->{cfg}{$name}) {
+ $self->_make_error('section or variable already exists');
+ return 0;
+ }
+ $self->{cfg}{$name} = { %inherited }; # inherit the values
+ push @{$self->{cfg_stack}}, $self->{cfg};
+ $self->{cfg} = $self->{cfg}{$name};
+
+ # keep track of the inherited values here;
+ # we delete it on the way up in _prev_level()
+ $self->{cfg}{_inherited} = \%inherited;
+
+ # list of already defined variables on this level
+ if (defined $self->{grammar}{_varlist}) {
+ $self->{cfg}{_varlist} = [];
+ }
+
+ # meta data for _mandatory test
+ $self->{grammar}{_is_section} = 1;
+ $self->{cfg}{_is_section} = 1;
+
+ # this uses the copy created above for regexp sections
+ # and the original for non-regexp sections (where $s == $name)
+ $self->{cfg}{_grammar} = $name;
+
+ $self->{cfg}{_order} = $order if defined $order;
+
+ # increase level
+ $self->{level}++;
+
+ # if there's a _dyn sub, apply it
+ if (defined $self->{grammar}{_dyn}) {
+ &{$self->{grammar}{_dyn}}($s, $name, $self->{grammar});
+ }
+
+ return 1;
+}
+
+# find variables in old grammar list 'listname'
+# that aren't in the corresponding list in the new grammar
+# and list them as a POD document, possibly with a callback
+# function 'docfunc'
+
+sub _findmissing($$$;$) {
+ my $old = shift;
+ my $new = shift;
+ my $listname = shift;
+ my $docfunc = shift;
+
+ my @doc;
+ if ($old->{$listname}) {
+ my %newlist;
+ if ($new->{$listname}) {
+ @newlist{@{$new->{$listname}}} = undef;
+ }
+ for my $v (@{$old->{$listname}}) {
+ next if exists $newlist{$v};
+ if ($docfunc) {
+ push @doc, &$docfunc($old, $v)
+ } else {
+ push @doc, "=item $v";
+ }
+ }
+ }
+ return @doc;
+}
+
+# find variables in new grammar list 'listname'
+# that aren't in the corresponding list in the new grammar
+#
+# this is just _findmissing with the arguments swapped
+
+sub _findnew($$$;$) {
+ my $old = shift;
+ my $new = shift;
+ my $listname = shift;
+ my $docfunc = shift;
+ return _findmissing($new, $old, $listname, $docfunc);
+}
+
+# compare two lists for element equality
+
+sub _listseq($$);
+sub _listseq($$) {
+ my ($k, $l) = @_;
+ my $length = @$k;
+ return 0 unless @$l == $length;
+ for (my $i=0; $i<$length; $i++) {
+ return 0 unless $k->[$i] eq $l->[$i];
+ }
+ return 1;
+}
+
+# diff two grammar trees, documenting the differences
+
+sub _diffgrammars($$);
+sub _diffgrammars($$) {
+ my $old = shift;
+ my $new = shift;
+ my @doc;
+
+ my @vdoc;
+ @vdoc = _findmissing($old, $new, '_vars');
+ push @doc, "The following variables are not valid anymore:", "=over" , @vdoc, "=back"
+ if @vdoc;
+ @vdoc = _findnew($old, $new, '_vars', \&_describevar);
+ push @doc, "The following new variables are valid:", "=over" , @vdoc, "=back"
+ if @vdoc;
+ @vdoc = _findmissing($old, $new, '_sections');
+ push @doc, "The following subsections are not valid anymore:", "=over" , @vdoc, "=back"
+ if @vdoc;
+ @vdoc = _findnew($old, $new, '_sections', sub {
+ my ($tree, $sec) = @_;
+ my @tdoc;
+ _genpod($tree->{$sec}, 0, \@tdoc);
+ return @tdoc;
+ });
+ push @doc, "The following new subsections are defined:", "=over" , @vdoc, "=back"
+ if @vdoc;
+ for (@{$old->{_sections}}) {
+ next unless exists $new->{$_};
+ @vdoc = _diffgrammars($old->{$_}, $new->{$_});
+ push @doc, "Syntax changes for subsection B<$_>", "=over", @vdoc, "=back"
+ if @vdoc;
+ }
+ return @doc;
+}
+
+
+sub _describevar {
+ my $tree = shift;
+ my $var = shift;
+ my $mandatory = ( $tree->{_mandatory} and
+ grep {$_ eq $var} @{$tree->{_mandatory}} ) ?
+ " I<(mandatory setting)>" : "";
+ my @doc;
+ push @doc, "=item B<$var>".$mandatory;
+ push @doc, $tree->{$var}{_doc} if $tree->{$var}{_doc} ;
+ my $inherited = ( $tree->{_inherited} and
+ grep {$_ eq $var} @{$tree->{_inherited}});
+ push @doc, "This variable I<inherits> its value from the parent section if nothing is specified here."
+ if $inherited;
+ push @doc, "This variable I<dynamically> modifies the grammar based on its value."
+ if $tree->{$var}{_dyn};
+ push @doc, "Default value: $var = $tree->{$var}{_default}"
+ if ($tree->{$var}{_default});
+ push @doc, "Example: $var = $tree->{$var}{_example}"
+ if ($tree->{$var}{_example});
+ return @doc;
+}
+
+sub _genpod($$$);
+sub _genpod($$$)
+{
+ my ($tree, $level, $doc) = @_;
+ my %dyndoc;
+ if ($tree->{_vars}){
+ push @{$doc}, "The following variables can be set in this section:";
+ push @{$doc}, "=over";
+ foreach my $var (@{$tree->{_vars}}){
+ push @{$doc}, _describevar($tree, $var);
+ }
+ push @{$doc}, "=back";
+ }
+
+ if ($tree->{_text}){
+ push @{$doc}, ($tree->{_text}{_doc} or "Unspecified Text content");
+ if ($tree->{_text}{_example}){
+ my $ex = $tree->{_text}{_example};
+ chomp $ex;
+ $ex = map {" $_"} split /\n/, $ex;
+ push @{$doc}, "Example:\n\n$ex\n";
+ }
+ }
+
+ if ($tree->{_table}){
+ push @{$doc}, ($tree->{_table}{_doc} or
+ "This section can contain a table ".
+ "with the following structure:" );
+ push @{$doc}, "=over";
+ for (my $i=0;$i < $tree->{_table}{_columns}; $i++){
+ push @{$doc}, "=item column $i";
+ push @{$doc}, ($tree->{_table}{$i}{_doc} or
+ "Unspecific Content");
+ push @{$doc}, "Example: $tree->{_table}{$i}{_example}"
+ if ($tree->{_table}{$i}{_example})
+ }
+ push @{$doc}, "=back";
+ }
+ if ($tree->{_sections}){
+ if ($level > 0) {
+ push @{$doc}, "The following sections are valid on level $level:";
+ push @{$doc}, "=over";
+ }
+ foreach my $section (@{$tree->{_sections}}){
+ my $mandatory = ( $tree->{_mandatory} and
+ grep {$_ eq $section} @{$tree->{_mandatory}} ) ?
+ " I<(mandatory section)>" : "";
+ push @{$doc}, ($level > 0) ?
+ "=item B<".("+" x $level)."$section>$mandatory" :
+ "=head2 *** $section ***$mandatory";
+ if ($tree eq $tree->{$section}) {
+ push @{$doc}, "This subsection has the same syntax as its parent.";
+ next;
+ }
+ push @{$doc}, ($tree->{$section}{_doc})
+ if $tree->{$section}{_doc};
+ push @{$doc}, "The grammar of this section is I<dynamically> modified based on its name."
+ if $tree->{$section}{_dyn};
+ if ($tree->{_recursive} and
+ grep {$_ eq $section} @{$tree->{_recursive}}) {
+ push @{$doc}, "This section is I<recursive>: it can contain subsection(s) with the same syntax.";
+ }
+ _genpod ($tree->{$section},$level+1,$doc);
+ next unless $tree->{$section}{_dyn} and $tree->{$section}{_dyndoc};
+ push @{$doc}, "Dynamical grammar changes for example instances of this section:";
+ push @{$doc}, "=over";
+ for my $name (sort keys %{$tree->{$section}{_dyndoc}}) {
+ my $newtree = _deepcopy($tree->{$section});
+ push @{$doc}, "=item B<$name>: $tree->{$section}{_dyndoc}{$name}";
+ &{$tree->{$section}{_dyn}}($section, $name, $newtree);
+ my @tdoc = _diffgrammars($tree->{$section}, $newtree);
+ if (@tdoc) {
+ push @{$doc}, @tdoc;
+ } else {
+ push @{$doc}, "No changes that can be automatically described.";
+ }
+ push @{$doc}, "(End of dynamical grammar changes for example instance C<$name>.)";
+ }
+ push @{$doc}, "=back";
+ push @{$doc}, "(End of dynamical grammar changes for example instances of section C<$section>.)";
+ }
+ push @{$doc}, "=back" if $level > 0
+ }
+ if ($tree->{_vars}) {
+ for my $var (@{$tree->{_vars}}) {
+ next unless $tree->{$var}{_dyn} and $tree->{$var}{_dyndoc};
+ push @{$doc}, "Dynamical grammar changes for example values of variable C<$var>:";
+ push @{$doc}, "=over";
+ for my $val (sort keys %{$tree->{$var}{_dyndoc}}) {
+ my $newtree = _deepcopy($tree);
+ push @{$doc}, "=item B<$val>: $tree->{$var}{_dyndoc}{$val}";
+ &{$tree->{$var}{_dyn}}($var, $val, $newtree);
+ my @tdoc = _diffgrammars($tree, $newtree);
+ if (@tdoc) {
+ push @{$doc}, @tdoc;
+ } else {
+ push @{$doc}, "No changes that can be automatically described.";
+ }
+ push @{$doc}, "(End of dynamical grammar changes for variable C<$var> example value C<$val>.)";
+ }
+ push @{$doc}, "=back";
+ push @{$doc}, "(End of dynamical grammar changes for example values of variable C<$var>.)";
+ }
+ }
+};
+
+sub makepod($) {
+ my $self = shift;
+ my $tree = $self->{grammar};
+ my @doc;
+ _genpod($tree,0,\@doc);
+ return join("\n\n", @doc)."\n";
+}
+
+
+sub _set_variable($$$)
+{
+ my $self = shift;
+ my $key = shift;
+ my $value = shift;
+
+ my $gn = $self->_search_variable($key);
+ defined $gn or return 0;
+
+ my $varlistref;
+ if (defined $self->{grammar}{_varlist}) {
+ $varlistref = $self->{cfg}{_varlist};
+ }
+
+ if (defined $self->{grammar}{$gn}) {
+ my $g = $self->{grammar}{$gn};
+
+ # check regular expression
+ if (defined $g->{_re}) {
+ $value =~ /^$g->{_re}$/ or do {
+ if (defined $g->{_re_error}) {
+ $self->_make_error($g->{_re_error});
+ }
+ else {
+ $self->_make_error("syntax error in value of '$key'");
+ }
+ return 0;
+ }
+ }
+ if (defined $g->{_sub}){
+ my $error = &{$g->{_sub}}($value, $varlistref);
+ if (defined $error){
+ $self->_make_error($error);
+ return 0;
+ }
+ }
+ # if there's a _dyn sub, apply it
+ if (defined $g->{_dyn}) {
+ &{$g->{_dyn}}($key, $value, $self->{grammar});
+ }
+ }
+ $self->{cfg}{$key} = $value;
+ push @{$varlistref}, $key if ref $varlistref;
+
+ return 1;
+}
+
+
+sub parse($$)
+{
+ my $self = shift;
+ my $file = shift;
+
+ $self->{cfg} = {};
+ $self->{level} = 0;
+ $self->{cfg_stack} = [];
+ $self->{grammar_stack} = [];
+ $self->{file_stack} = [];
+ $self->{line_stack} = [];
+
+ # we work with a copy of the grammar so the _dyn subs may change it
+ local $self->{grammar} = _deepcopy($self->{grammar});
+
+ $self->_parse_file($file) or return undef;
+
+ $self->_goto_level(0, undef) or return undef;
+
+ # fill in the top level values from _default keywords
+ $self->_fill_defaults;
+
+ $self->_check_mandatory($self->{grammar}, $self->{cfg}, undef)
+ or return undef;
+
+ return $self->{cfg};
+
+}
+
+=head1 NAME
+
+Config::Grammar::Dynamic - A grammar-based, user-friendly config parser
+
+=head1 DESCRIPTION
+
+Config::Grammar::Dynamic is like Config::Grammar but with some additional
+features useful for building configuration grammars that are dynamic, i.e.
+where the syntax changes according to configuration entries in the same file.
+
+The following keys can be additionally specified in the grammar when using this
+module:
+
+=head2 Special Section Keys
+
+=over 12
+
+=item _dyn
+
+A subroutine reference (function pointer) that will be called when
+a new section of this syntax is encountered. The subroutine will get
+three arguments: the syntax of the section name (string or regexp), the
+actual name encountered (this will be the same as the first argument for
+non-regexp sections) and a reference to the grammar tree of the section.
+This subroutine can then modify the grammar tree dynamically.
+
+=item _dyndoc
+
+A hash reference that lists interesting names for the section that
+should be documented. The keys of the hash are the names and the
+values in the hash are strings that can contain an explanation
+for the name. The _dyn() subroutine is then called for each of
+these names and the differences of the resulting grammar and
+the original one are documented. This module can currently document
+differences in the _vars list, listing new variables and removed
+ones, and differences in the _sections list, listing the
+new and removed sections.
+
+=item _recursive
+
+Array containing the list of those sub-sections that are I<recursive>, ie.
+that can contain a new sub-section with the same syntax as themselves.
+
+The same effect can be accomplished with circular references in the
+grammar tree or a suitable B<_dyn> section subroutine (see below},
+so this facility is included just for convenience.
+
+=back
+
+=head2 Special Variable Keys
+
+=over 12
+
+=item _dyn
+
+A subroutine reference (function pointer) that will be called when the
+variable is assigned some value in the config file. The subroutine will
+get three arguments: the name of the variable, the value assigned and
+a reference to the grammar tree of this section. This subroutine can
+then modify the grammar tree dynamically.
+
+Note that no _dyn() call is made for default and inherited values of
+the variable.
+
+=item _dyndoc
+
+A hash reference that lists interesting values for the variable that
+should be documented. The keys of the hash are the values and the
+values in the hash are strings that can contain an explanation
+for the value. The _dyn() subroutine is then called for each of
+these values and the differences of the resulting grammar and
+the original one are documented. This module can currently document
+differences in the _vars list, listing new variables and removed
+ones, and differences in the _sections list, listing the
+new and removed sections.
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright (c) 2000-2005 by ETH Zurich. All rights reserved.
+Copyright (c) 2007 by David Schweikert. All rights reserved.
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head1 AUTHORS
+
+David Schweikert,
+Tobias Oetiker,
+Niko Tyni
+
+=cut
+
+# Emacs Configuration
+#
+# Local Variables:
+# mode: cperl
+# eval: (cperl-set-style "PerlStyle")
+# mode: flyspell
+# mode: flyspell-prog
+# End:
+#
+# vi: sw=4
diff --git a/lib/Smokeping.pm b/lib/Smokeping.pm
index f870d05..e34cab5 100644
--- a/lib/Smokeping.pm
+++ b/lib/Smokeping.pm
@@ -9,7 +9,7 @@ use Digest::MD5 qw(md5_base64);
use SNMP_util;
use SNMP_Session;
use POSIX;
-use Config::Grammar;
+use Smokeping::Config;
use RRDs;
use Sys::Syslog qw(:DEFAULT setlogsock);
use Sys::Hostname;
@@ -2175,7 +2175,7 @@ DOC
},
}; # $PROBES
- my $parser = Config::Grammar->new
+ my $parser = Smokeping::Config->new
(
{
_sections => [ qw(General Database Presentation Probes Targets Alerts Slaves) ],
diff --git a/lib/Smokeping/Config.pm b/lib/Smokeping/Config.pm
new file mode 100644
index 0000000..6c92e19
--- /dev/null
+++ b/lib/Smokeping/Config.pm
@@ -0,0 +1,15 @@
+# provide backward compatibility for Config::Grammar
+package Smokeping::Config;
+
+BEGIN {
+ require Config::Grammar;
+ if($Config::Grammar::VERSION ge '1.10') {
+ require Config::Grammar::Dynamic;
+ @ISA = qw(Config::Grammar::Dynamic);
+ }
+ else {
+ @ISA = qw(Config::Grammar);
+ }
+}
+
+1;