diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2017-03-03 13:06:21 +0200 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2017-03-03 13:16:07 +0200 |
commit | 8fbdd4a7c56de2752c866ce3283d3bdbca3ed8bb (patch) | |
tree | 70e40d98777ce5a748dd48b07c1ab8ab460506b1 /lib | |
parent | c437dd558ef7d4e2f3b511d998d100d395c5ba26 (diff) | |
download | beam-8fbdd4a7c56de2752c866ce3283d3bdbca3ed8bb.tar.gz beam-8fbdd4a7c56de2752c866ce3283d3bdbca3ed8bb.tar.bz2 |
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.
Diffstat (limited to 'lib')
-rw-r--r-- | lib/App/Beam/Config.pm | 226 |
1 files changed, 171 insertions, 55 deletions
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<sort> 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<error> 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<parse>. + =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}; } |