From 8fbdd4a7c56de2752c866ce3283d3bdbca3ed8bb Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Fri, 3 Mar 2017 13:06:21 +0200 Subject: Implement lint() method * lib/App/Beam/Config.pm: Keep count of errors in the error_count member. (getref): Take into account the {ci} setting. (flatten): Minor fix. (lint): New method. * t/TestConfig.pm (lint): Overload method. * t/conf06.t: New test case. --- lib/App/Beam/Config.pm | 226 +++++++++++++++++++++++++++++++++++++------------ t/TestConfig.pm | 15 ++++ t/conf06.t | 48 +++++++++++ 3 files changed, 234 insertions(+), 55 deletions(-) create mode 100644 t/conf06.t diff --git a/lib/App/Beam/Config.pm b/lib/App/Beam/Config.pm index bca710a..47a846e 100644 --- a/lib/App/Beam/Config.pm +++ b/lib/App/Beam/Config.pm @@ -344,40 +344,35 @@ sub check_mandatory { if (ref($d) eq 'HASH') { if ($d->{mandatory} && !exists($section->{$k})) { $loc = $section->{-locus} if exists($section->{-locus}); - if (exists($d->{section})) { - $self->error("mandatory section [" - . join(' ', @_, $k) - . "] not present", - locus => $loc); - ++$err; - } else { - $self->error("mandatory variable \"" - . join('.', @_, $k) - . "\" not set", - locus => $loc); - ++$err; - } + $self->error(exists($d->{section}) + ? "mandatory section [" + . join(' ', @_, $k) + . "] not present" + : "mandatory variable \"" + . join('.', @_, $k) + . "\" not set", + locus => $loc); + $self->{error_count}++; } if (exists($d->{section})) { if ($k eq '*') { while (my ($name, $vref) = each %{$section}) { if (is_section_ref($vref)) { - $err += $self->check_mandatory($d->{section}, - $vref, - $loc, - @_, $name); + $self->check_mandatory($d->{section}, + $vref, + $loc, + @_, $name); } } } elsif (exists($section->{$k})) { - $err += $self->check_mandatory($d->{section}, - $section->{$k}, - $loc, - @_, $k); + $self->check_mandatory($d->{section}, + $section->{$k}, + $loc, + @_, $k); } } } } - return $err; } sub readconfig { @@ -390,11 +385,11 @@ sub readconfig { open(my $fd, "<", $file) or do { $self->error("can't open configuration file $file: $!"); - return 1; + $self->{error_count}++; + return 0; }; my $line; - my $err; my $section = $conf; my $kw = $self->{parameters}; my $include = 0; @@ -423,9 +418,11 @@ sub readconfig { $include = 1; } else { ($section, $rootname, $kw) = $self->parse_section($conf, $1); - $self->error("unknown section", - locus => new App::Beam::Config::Locus($file, $line)) - if (exists($self->{parameters}) and !defined($kw)); + if (exists($self->{parameters}) and !defined($kw)) { + $self->error("unknown section", + locus => new App::Beam::Config::Locus($file, $line)); + $self->{error_count}++; + } if ($self->{locations}) { $section->{-locus} = new App::Beam::Config::Locus($file, $line) @@ -439,18 +436,17 @@ sub readconfig { if ($include) { if ($k eq 'path') { - $err += $self->readconfig($v, $conf, include => 1); + $self->readconfig($v, $conf, include => 1); } elsif ($k eq 'pathopt') { - $err += $self->readconfig($v, $conf, include => 1) - if -f $v; + $self->readconfig($v, $conf, include => 1) if -f $v; } elsif ($k eq 'glob') { foreach my $file (bsd_glob($v, 0)) { - $err += $self->readconfig($file, $conf, include => 1); + $self->readconfig($file, $conf, include => 1); } } else { $self->error("keyword \"$k\" is unknown", locus => new App::Beam::Config::Locus($file, $line)); - ++$err; + $self->{error_count}++; } next; } @@ -461,7 +457,7 @@ sub readconfig { if (!defined($x)) { $self->error("keyword \"$k\" is unknown", locus => new App::Beam::Config::Locus($file, $line)); - ++$err; + $self->{error_count}++; next; } elsif (ref($x) eq 'HASH') { my $errstr; @@ -476,7 +472,7 @@ sub readconfig { if ($v !~ /$x->{re}/) { $self->error("invalid value for $k", locus => new App::Beam::Config::Locus($file, $line)); - ++$err; + $self->{error_count}++; next; } } @@ -485,7 +481,7 @@ sub readconfig { if (defined($errstr = &{$x->{check}}(\$v, $prev_val))) { $self->error($errstr, locus => new App::Beam::Config::Locus($file, $line)); - ++$err; + $self->{error_count}++; next; } } @@ -512,15 +508,15 @@ sub readconfig { } else { $self->error("malformed line", locus => new App::Beam::Config::Locus($file, $line)); - ++$err; + $self->{error_count}++; next; } } close $fd; - $err += $self->check_mandatory($self->{parameters}, $conf, - new App::Beam::Config::Locus($file, $line)) + $self->check_mandatory($self->{parameters}, $conf, + new App::Beam::Config::Locus($file, $line)) unless $_{include}; - return $err; + return $self->{error_count} == 0; } sub fixup { @@ -556,6 +552,8 @@ sub parse { my ($self) = @_; my %conf; + return if exists $self->{conf}; + $self->{error_count} = 0; if (exists($self->{cachefile}) and -f $self->{cachefile}) { if ($self->file_up_to_date($self->{cachefile})) { my $ref; @@ -573,13 +571,14 @@ sub parse { } $self->debug(1, "parsing $self->{filename}"); - my $err = $self->readconfig($self->{filename}, \%conf); - if ($err == 0) { + $self->readconfig($self->{filename}, \%conf); + if ($self->{error_count} == 0) { $self->{conf} = \%conf ; $self->{updated} = 1; $self->fixup($self->{parameters}) if exists $self->{parameters}; + return 1; } - return !$err; + return 0; } sub getref { @@ -588,8 +587,9 @@ sub getref { return undef unless exists $self->{conf}; my $ref = $self->{conf}; for (@_) { - return undef unless exists $ref->{$_}; - $ref = $ref->{$_}; + my $k = $self->{ci} ? lc($_) : $_; + return undef unless exists $ref->{$k}; + $ref = $ref->{$k}; } return $ref; } @@ -828,12 +828,6 @@ sub names_of { # return @{[ each %{$self->{conf}} ]}; #} -use constant { - NO_SORT => 0, - SORT_NATURAL => 1, - SORT_PATH => 2 -}; - =head2 @array = $cfg->flatten() =head2 @array = $cfg->flatten(sort => $sort) @@ -861,6 +855,16 @@ mode is enabled. =back +=cut + +use constant { + NO_SORT => 0, + SORT_NATURAL => 1, + SORT_PATH => 2 +}; + +=pod + The I<$sort> argument controls the ordering of the entries in the returned B<@array>. It is either a code reference suitable to pass to the Perl B function, or one of the following constants: @@ -891,15 +895,16 @@ ones you need, or use the B<:sort> keyword to import them all, e.g.: @array = $cfg->flatten(sort => SORT_PATH); =cut - + sub flatten { my $self = shift; local %_ = @_; - my $sort = delete($_{sort}) || SORT_NATURAL; + my $sort = delete($_{sort}); + $sort = SORT_NATURAL unless defined($sort); my @ar; my $i; - croak "unrecognized keyworf arguments: ". join(',', keys %_) + croak "unrecognized keyword arguments: ". join(',', keys %_) if keys %_; push @ar, [ [], $self->{conf} ]; @@ -922,16 +927,127 @@ sub flatten { } else { croak "unsupported sort value"; } - + shift @ar; # toss off first entry return &{$sort}(map { exists($_->[1]{-value}) ? $_ : () } @ar); } =head2 $cfg->lint(\%synt) +Checks the syntax according to the syntax table B<%synt>. On success, +applies eventual default values and returns true. On errors, reports +them using B and returns false. + +This method provides a way to delay syntax checking for a later time, +which is useful, e.g. if some parts of the parser are loaded as modules +after calling B. + =cut sub lint { my ($self, $synt) = @_; - + my @skip; + outer: + foreach my $dump ($self->flatten(sort => SORT_PATH)) { + if (@skip) { + for (my $i = 0; $ <= $#{$dump->[0]}; $i++) { + next outer if $i > $#skip; + my $k = $dump->[0][$i]; + $k = lc($k) if $self->{ci}; + last if $skip[$i] ne $k; + } + @skip = undef; + } + + my $sref = $synt; + my @domain; + for (my $i = 0; $i <= $#{$dump->[0]}; $i++) { + my $k = $dump->[0][$i]; + $k = lc($k) if $self->{ci}; + if (exists($sref->{$k})) { + push @domain, $k; + $sref = $sref->{$k}; + } elsif (exists($sref->{'*'})) { + push @domain, $k; + $sref = $sref->{'*'}; + } else { + if (@domain) { + my %opts; + $opts{locus} = $dump->[1]{-locus} + if exists($dump->[1]{-locus}); + if (exists($dump->[1]{-section})) { + $self->error("unknown section", %opts); + $self->{error_count}++; + @skip = @domain; + } else { + $self->error("keyword \"$k\" is unknown", %opts); + $self->{error_count}++; + } + } + next outer; + } + + if (ref($sref) ne 'HASH') { + $sref = {}; + } elsif (exists($sref->{section})) { + $sref = $sref->{section}; + } + } + + my %opts; + $opts{locus} = $dump->[1]{-locus} if exists($dump->[1]{-locus}); + my $k = ${$dump->[0]}[-1]; + my $val = $dump->[1]{-value}; + if (ref($val) eq 'ARRAY') { + if ($sref->{array}) { + my @ar; + foreach my $v (@$val) { + if (exists($sref->{re})) { + if ($v !~ /$sref->{re}/) { + $self->error("invalid value for $k", %opts); + $self->{error_count}++; + next; + } + } + if (exists($sref->{check})) { + my $errstr = &{$sref->{check}}(\$v, + @ar ? $ar[-1] : undef); + if (defined($errstr)) { + $self->error($errstr, %opts); + $self->{error_count}++; + next; + } + push @ar, $v; + } + } + $dump->[1]{-value} = \@ar; + next; + } else { + $val = pop($val); + } + } + + if (exists($sref->{re})) { + if ($val !~ /$sref->{re}/) { + $self->error("invalid value for $k", %opts); + $self->{error_count}++; + next; + } + } + + if (exists($sref->{check})) { + if (defined(my $errstr = &{$sref->{check}}(\$val))) { + $self->error($errstr, %opts); + $self->{error_count}++; + next; + } + } + + $dump->[1]{-value} = $val; + } + + $self->check_mandatory($synt, $self->{conf}); + return 0 if $self->{error_count}; + $self->fixup($synt); + return !$self->{error_count}; } diff --git a/t/TestConfig.pm b/t/TestConfig.pm index 63b9d06..7f8f232 100644 --- a/t/TestConfig.pm +++ b/t/TestConfig.pm @@ -88,3 +88,18 @@ sub errors { return undef if $self->success; return @{$self->{errors}}; } + +sub lint { + my $self = shift; + my $synt = shift; + local %_ = @_; + my $exp = $self->{expected_errors} = delete $_{expect}; + carp "unknown parameters: " . join(', ', keys(%_)) if (keys(%_)); + + $self->SUPER::lint($synt); + + if ($exp && @{$self->{expected_errors}}) { + $self->{status} = 0; + $self->error("not all expected errors reported"); + } +} diff --git a/t/conf06.t b/t/conf06.t new file mode 100644 index 0000000..219a5e4 --- /dev/null +++ b/t/conf06.t @@ -0,0 +1,48 @@ +# -*- perl -*- +use lib 't'; +use strict; +use Test; +use TestConfig; +use Data::Dumper; + +plan(tests => 2); + +my %keywords = ( + core => { + section => { + 'retain-interval' => { mandatory => 1 }, + 'tempdir' => 1, + 'verbose' => 1, + } + }, + '*' => 1 +); + +my $cfg = new TestConfig(locations => 1, parameters => \%keywords); +ok($cfg->canonical, 'backend.file.level=3 backend.file.local=1 core.retain-interval=10 core.tempdir="/tmp"'); + +my %subkw = ( + backend => { + section => { + file => { + section => { + name => { mandatory => 1 }, + local => 1 + } + } + } + } +); + +ok(!$cfg->lint(\%subkw, + expect => [ 'keyword "level" is unknown', + 'mandatory variable "backend.file.name" not set' ])); + +__DATA__ +# This is a sample configuration file +[core] + retain-interval = 10 + tempdir = /tmp +[backend file] + local = 1 + level = 3 -- cgit v1.2.1