aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/App/Beam/Config.pm209
1 files changed, 94 insertions, 115 deletions
diff --git a/lib/App/Beam/Config.pm b/lib/App/Beam/Config.pm
index d3ff4f7..32c1a32 100644
--- a/lib/App/Beam/Config.pm
+++ b/lib/App/Beam/Config.pm
@@ -276,10 +276,9 @@ sub writecache {
}
sub parse_section {
- my ($self, $conf, $input) = @_;
+ my ($self, $conf, $input, $locus) = @_;
my $ref = $conf;
my $quote;
- my $rootname;
my $kw = $self->{parameters} if exists $self->{parameters};
while ($input ne '') {
my $name;
@@ -308,8 +307,10 @@ sub parse_section {
}
if (defined($name)) {
- $rootname = $name unless defined $rootname;
- $ref->{$name} = {} unless ref($ref->{$name}) eq 'HASH';
+ $ref->{$name} = {
+ -order => $self->{order}++,
+ -locus => $locus
+ } unless ref($ref->{$name}) eq 'HASH';
$ref = $ref->{$name};
if (defined($kw)
@@ -320,7 +321,7 @@ sub parse_section {
$name = undef;
}
}
- return ($ref, $rootname, $kw);
+ return ($ref, $kw);
}
sub check_mandatory {
@@ -331,7 +332,7 @@ sub check_mandatory {
my $err = 0;
while (my ($k, $d) = each %{$kw}) {
- if (ref($d) eq 'HASH') {
+ if (ref($d) eq 'HASH') {
if ($d->{mandatory} && !exists($section->{$k})) {
$loc = $section->{-locus} if exists($section->{-locus});
$self->error(exists($d->{section})
@@ -347,14 +348,20 @@ sub check_mandatory {
if (exists($d->{section})) {
if ($k eq '*') {
while (my ($name, $vref) = each %{$section}) {
- if (is_section_ref($vref)) {
+ next if $name =~ /^-/;
+ if (exists($d->{select})
+ && !&{$d->{select}}($vref, @_, $name)) {
+ next;
+ } elsif (is_section_ref($vref)) {
$self->check_mandatory($d->{section},
$vref,
$loc,
@_, $name);
}
}
- } elsif (exists($section->{$k})) {
+ } elsif (exists($section->{$k})
+ && (!exists($d->{select})
+ || &{$d->{select}}($section->{$k}, @_, $k))) {
$self->check_mandatory($d->{section},
$section->{$k},
$loc,
@@ -369,7 +376,6 @@ sub readconfig {
my $self = shift;
my $file = shift;
my $conf = shift;
- local %_ = @_;
$self->debug(1, "reading file $file");
open(my $fd, "<", $file)
@@ -383,7 +389,6 @@ sub readconfig {
my $section = $conf;
my $kw = $self->{parameters};
my $include = 0;
- my $rootname;
while (<$fd>) {
++$line;
@@ -407,7 +412,8 @@ sub readconfig {
if ($arg eq 'include') {
$include = 1;
} else {
- ($section, $rootname, $kw) = $self->parse_section($conf, $1);
+ ($section, $kw) = $self->parse_section($conf, $1,
+ new App::Beam::Config::Locus($file, $line));
if (exists($self->{parameters}) and !defined($kw)) {
$self->error("unknown section",
locus => new App::Beam::Config::Locus($file, $line));
@@ -424,12 +430,12 @@ sub readconfig {
if ($include) {
if ($k eq 'path') {
- $self->readconfig($v, $conf, include => 1);
+ $self->readconfig($v, $conf);
} elsif ($k eq 'pathopt') {
- $self->readconfig($v, $conf, include => 1) if -f $v;
+ $self->readconfig($v, $conf) if -f $v;
} elsif ($k eq 'glob') {
foreach my $file (bsd_glob($v, 0)) {
- $self->readconfig($file, $conf, include => 1);
+ $self->readconfig($file, $conf);
}
} else {
$self->error("keyword \"$k\" is unknown",
@@ -499,9 +505,6 @@ sub readconfig {
}
}
close $fd;
- $self->check_mandatory($self->{parameters}, $conf,
- new App::Beam::Config::Locus($file, $line))
- unless $_{include};
return $self->{error_count} == 0;
}
@@ -558,6 +561,8 @@ sub parse {
$self->debug(1, "parsing $self->{filename}");
$self->readconfig($self->{filename}, \%conf);
+ $self->check_mandatory($self->{parameters}, \%conf);
+
if ($self->{error_count} == 0) {
$self->{conf} = \%conf ;
$self->{updated} = 1;
@@ -924,87 +929,41 @@ sub flatten {
return &{$sort}(map { exists($_->[1]{-value}) ? $_ : () } @ar);
}
-=head2 $cfg->lint(\%synt)
+sub __lint {
+ my ($self, $syntax, $vref, @path) = @_;
-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++) {
- $sref = $self->descend_synt($sref, $dump->[0][$i]);
- if (defined($sref)) {
- push @domain, $dump->[0][$i];
- } 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 \"$dump->[0][$i]\" is unknown",
- %opts);
- $self->{error_count}++;
- }
- }
- next outer;
- }
-
- if (exists($sref->{select}) && !&{$sref->{select}}(@$dump)) {
- next outer;
- }
+ return unless ref($syntax) eq 'HASH';
+ if (exists($syntax->{section})) {
+ return unless is_section_ref($vref);
+ } else {
+ return if is_section_ref($vref);
+ }
- if (exists($sref->{section})) {
- $sref = $sref->{section};
- } elsif ($i < $#{$dump->[0]}) {
- next outer;
- }
- }
+ if (exists($syntax->{select}) && !&{$syntax->{select}}($vref, @path)) {
+ print "IGNORE @path\n";
+ return;
+ }
- my %opts;
- $opts{locus} = $dump->[1]{-locus} if exists($dump->[1]{-locus});
- my $k = ${$dump->[0]}[-1];
- my $val = $dump->[1]{-value};
+ if (is_section_ref($vref)) {
+ $self->_lint($syntax->{section}, $vref, @path);
+ } else {
+ my $val = $vref->{-value};
+ my %opts = { locus => $vref->{-locus} };
+
if (ref($val) eq 'ARRAY') {
- if ($sref->{array}) {
+ if ($syntax->{array}) {
my @ar;
foreach my $v (@$val) {
- if (exists($sref->{re})) {
- if ($v !~ /$sref->{re}/) {
- $self->error("invalid value for $k", %opts);
+ if (exists($syntax->{re})) {
+ if ($v !~ /$syntax->{re}/) {
+ $self->error("invalid value for $path[-1]", %opts);
$self->{error_count}++;
next;
}
}
- if (exists($sref->{check})) {
- my $errstr = &{$sref->{check}}(\$v,
- @ar ? $ar[-1] : undef);
+ if (exists($syntax->{check})) {
+ my $errstr = &{$syntax->{check}}(\$v,
+ @ar ? $ar[-1] : undef);
if (defined($errstr)) {
$self->error($errstr, %opts);
$self->{error_count}++;
@@ -1013,51 +972,71 @@ sub lint {
push @ar, $v;
}
}
- $dump->[1]{-value} = \@ar;
- next;
+ $vref->{-value} = \@ar;
+ return;
} else {
- $val = pop($val);
+ $val = pop(@$val);
}
}
- if (exists($sref->{re})) {
- if ($val !~ /$sref->{re}/) {
- $self->error("invalid value for $k", %opts);
+ if (exists($syntax->{re})) {
+ if ($val !~ /$syntax->{re}/) {
+ $self->error("invalid value for $path[-1]", %opts);
$self->{error_count}++;
- next;
+ return;
}
}
- if (exists($sref->{check})) {
- if (defined(my $errstr = &{$sref->{check}}(\$val))) {
+ if (exists($syntax->{check})) {
+ if (defined(my $errstr = &{$syntax->{check}}(\$val))) {
$self->error($errstr, %opts);
$self->{error_count}++;
- next;
+ return;
}
}
- $dump->[1]{-value} = $val;
+ $vref->{-value} = $val;
}
-
- $self->check_mandatory($synt, $self->{conf});
- return 0 if $self->{error_count};
- $self->fixup($synt);
- return !$self->{error_count};
}
-sub descend_synt {
- my ($self, $sref, $k) = @_;
- $k = lc($k) if $self->{ci};
+sub _lint {
+ my ($self, $syntab, $conf, @path) = @_;
- if (exists($sref->{$k})) {
- $sref = $sref->{$k};
- } elsif (exists($sref->{'*'})) {
- $sref = $sref->{'*'};
- } else {
- return undef;
+ while (my ($var, $value) = each %$conf) {
+ next if $var =~ /^-/;
+ if (exists($syntab->{$var})) {
+ $self->__lint($syntab->{$var}, $value, @path, $var);
+ } elsif (exists($syntab->{'*'})) {
+ $self->__lint($syntab->{'*'}, $value, @path, $var);
+ } elsif (is_section_ref($value)) {
+ next;
+ } else {
+ $self->error("keyword \"$var\" is unknown",
+ locus => $value->{-locus});
+ }
}
+}
- return {} unless ref($sref) eq 'HASH';
+=head2 $cfg->lint(\%synt)
- return $sref;
+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) = @_;
+
+# $synt->{'*'} = { section => { '*' => 1 }} ;
+ $self->_lint($synt, $self->{conf});
+ $self->check_mandatory($synt, $self->{conf});
+ return 0 if $self->{error_count};
+ $self->fixup($synt);
+ return !$self->{error_count};
}
+

Return to:

Send suggestions and report system problems to the System administrator.