diff options
-rw-r--r-- | lib/App/Beam/Config.pm | 209 |
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}; } + |