diff options
| -rw-r--r-- | CHANGES | 2 | ||||
| -rw-r--r-- | etc/config.dist | 8 | ||||
| -rw-r--r-- | lib/Config/Grammar.pm | 403 | ||||
| -rw-r--r-- | lib/Config/Grammar/Dynamic.pm | 556 | ||||
| -rw-r--r-- | lib/Smokeping.pm | 4 | ||||
| -rw-r--r-- | lib/Smokeping/Config.pm | 15 |
6 files changed, 668 insertions, 320 deletions
@@ -1,3 +1,5 @@ +* switched to config grammar 1.10 (pre release) -- tobi + * make sure reload_config reloads in any case even when the config has not changed ... with this we solve the problem that maybe some @include configs have changed which we would not find out otherwise -- tobi diff --git a/etc/config.dist b/etc/config.dist index cd57ed0..1af1c39 100644 --- a/etc/config.dist +++ b/etc/config.dist @@ -9,8 +9,8 @@ imgurl = cache datadir = /tmp/smokeping-ms/data piddir = /tmp/smokeping-ms/var cgiurl = http://some.url/smokeping.cgi -smokemail = /scratch/oetiker/smoke-master/etc/smokemail.dist -tmail = /scratch/oetiker/smoke-master/etc/tmail.dist +smokemail = /home/oetiker/checkouts/smokeping/trunk/software/etc/smokemail.dist +tmail = /home/oetiker/checkouts/smokeping/trunk/software/etc/tmail.dist # specify this to get syslog logging syslogfacility = local0 # each probe is now run in its own process @@ -44,7 +44,7 @@ AVERAGE 0.5 144 720 *** Presentation *** -template = /scratch/oetiker/smoke-master/etc/basepage.html.dist +template = /home/oetiker/checkouts/smokeping/trunk/software/etc/basepage.html.dist + charts @@ -99,7 +99,7 @@ unison_tolerance = 2 binary = /usr/sbin/fping *** Slaves *** -secrets=/scratch/oetiker/smoke-master/etc/smokeping_secrets.dist +secrets=/home/oetiker/checkouts/smokeping/trunk/software/etc/smokeping_secrets.dist +boomer display_name=boomer color=0000ff 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; |