aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/App/Beam/Config.pm226
-rw-r--r--t/TestConfig.pm15
-rw-r--r--t/conf06.t48
3 files changed, 234 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};
}
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

Return to:

Send suggestions and report system problems to the System administrator.