File Coverage

lib/Config/Grammar.pm

Criterion	Covered	Total	%
statement	271	382	70.9
branch	120	212	56.6
condition	3	21	14.2
subroutine	21	24	87.5
pod	0	6	0.0
total	415	645	64.3

package Config::Grammar;
use strict;

$Config::Grammar::VERSION = '1.13';

sub new($$)
{
    my $proto   = shift;
    my $grammar = shift;
    my $class   = ref($proto) || $proto;

    my $self = {grammar => $grammar};
    bless($self, $class);
    return $self;
}

sub err($)
{
    my $self = shift;
    return $self->{'err'};
}

sub _make_error($$)
{
    my $self = shift;
    my $text = shift;
    $self->{'err'} = "$self->{file}, line $self->{line}: $text";
}

sub _peek($)
{
    my $a = shift;
    return $a->[$#$a];
}

sub _quotesplit($)
{
    my $line = shift;
    my @items;
    while ($line ne "") {
        if ($line =~ s/^"((?:\\.|[^"])*)"\s*//) {
            my $frag = $1;
            $frag =~ s/\\(.)/$1/g;
            push @items, $frag;
        } elsif ($line =~ s/^'((?:\\.|[^'])*)'\s*//) {
            my $frag = $1;
            $frag =~ s/\\(.)/$1/g;
            push @items, $frag;
        }
        elsif ($line =~ s/^((?:\\.|[^\s])*)(?:\s+|$)//) {
            my $frag = $1;
            $frag =~ s/\\(.)/$1/g;
            push @items, $frag;
        }
        else {
            die "Internal parser error for '$line'";
        }
    }
    return @items;
}

sub _check_mandatory($$$$)
{
    my $self    = shift;
    my $g       = shift;
    my $c       = shift;
    my $section = shift;

    # check _mandatory sections, variables and tables
    if (defined $g->{_mandatory}) {
        for (@{$g->{_mandatory}}) {
            if (not defined $g->{$_}) {
                $g->{$_} = {};
            }
            if (not defined $c->{$_}) {
                if (defined $section) {
                    $self->{'err'} .= "$self->{file} ($section): ";
                }
                else {
                    $self->{'err'} = "$self->{file}: ";
                }

                if (defined $g->{$_}{_is_section}) {
                    $self->{'err'} .= "mandatory (sub)section '$_' not defined";
                }
                elsif ($_ eq '_table') {
                    $self->{'err'} .= "mandatory table not defined";
                }
                else {
                    $self->{'err'} .= "mandatory variable '$_' not defined";
                }
                return 0;
            }
        }
    }

    for (keys %$c) {

        # do some cleanup
        ref $c->{$_} eq 'HASH' or next;
        defined $c->{$_}{_is_section} or next;
        $self->_check_mandatory($g->{$c->{$_}{_grammar}}, $c->{$_},
          defined $section ? "$section/$_" : "$_") or return 0;
        delete $c->{$_}{_is_section};
        delete $c->{$_}{_grammar};
        delete $c->{$_}{_order_count} if exists $c->{$_}{_order_count};
    }

    return 1;
}

######### SECTIONS #########

# search grammar definition of a section
sub _search_section($$)
{
    my $self = shift;
    my $name = shift;

    if (not defined $self->{grammar}{_sections}) {
        $self->_make_error("no sections are allowed");
        return undef;
    }

    # search exact match
    for (@{$self->{grammar}{_sections}}) {
        if ($name eq $_) {
            return $_;
        }
    }

    # search regular expression
    for (@{$self->{grammar}{_sections}}) {
        if (m|^/(.*)/$|) {
            if ($name =~ /^$1$/) {
                return $_;
            }
        }
    }

    # no match
    $self->_make_error("unknown section '$name'");
    return undef;
}

# fill in default values for this section
sub _fill_defaults ($) {
    my $self = shift;
    my $g = $self->{grammar};
    my $c = $self->{cfg};
    if ($g->{_vars}) {
        for my $var (@{$g->{_vars}}) {
                next if exists $c->{$var};
                my $value = $g->{$var}{_default}
                  if exists $g->{$var}{_default};
                next unless defined $value;
                $c->{$var} = $value;
        }
    }

}

sub _next_level($$$)
{
    my $self = shift;
    my $name = shift;

    # section name
    if (defined $self->{section}) {
        $self->{section} .= "/$name";
    }
    else {
        $self->{section} = $name;
    }

    # grammar context
    my $s = $self->_search_section($name);
    return 0 unless defined $s;
    if (not defined $self->{grammar}{$s}) {
        $self->_make_error("Config::Grammar internal error (no grammar for $s)");
        return 0;
    }
    push @{$self->{grammar_stack}}, $self->{grammar};
    $self->{grammar} = $self->{grammar}{$s};

    # support for inherited values
    # note that we have to do this on the way down
    # and keep track of which values were inherited
    # so that we can propagate the values even further
    # down if needed
    my %inherited;
    if ($self->{grammar}{_inherited}) {
        for my $var (@{$self->{grammar}{_inherited}}) {
                next unless exists $self->{cfg}{$var};
                my $value = $self->{cfg}{$var};
                next unless defined $value;
                next if ref $value; # it's a section
                $inherited{$var} = $value;
        }
    }

    # config context
    my $order;
    if (defined $self->{grammar}{_order}) {
        if (defined $self->{cfg}{_order_count}) {
            $order = ++$self->{cfg}{_order_count};
        }
        else {
            $order = $self->{cfg}{_order_count} = 0;
        }
    }

    if (defined $self->{cfg}{$name}) {
        $self->_make_error('section or variable already exists');
        return 0;
    }
    $self->{cfg}{$name} = { %inherited }; # inherit the values
    push @{$self->{cfg_stack}}, $self->{cfg};
    $self->{cfg} = $self->{cfg}{$name};

    # keep track of the inherited values here;
    # we delete it on the way up in _prev_level()
    $self->{cfg}{_inherited} = \%inherited;

    # list of already defined variables on this level
    if (defined $self->{grammar}{_varlist}) {
	$self->{cfg}{_varlist} = [];
    }

    # meta data for _mandatory test
    $self->{grammar}{_is_section} = 1;
    $self->{cfg}{_is_section}     = 1;
    $self->{cfg}{_grammar}        = $s;
    $self->{cfg}{_order} = $order if defined $order;

    # increase level
    $self->{level}++;

    return 1;
}

sub _prev_level($)
{
    my $self = shift;

    # fill in the values from _default keywords when going up
    $self->_fill_defaults;

    # section name
    if (defined $self->{section}) {
        if ($self->{section} =~ /\//) {
            $self->{section} =~ s/\/.*?$//;
        }
        else {
            $self->{section} = undef;
        }
    }

    # clean up the _inherited hash, we won't need it anymore
    delete $self->{cfg}{_inherited};

    # config context
    $self->{cfg} = pop @{$self->{cfg_stack}};

    # grammar context
    $self->{grammar} = pop @{$self->{grammar_stack}};

    # decrease level
    $self->{level}--;
}

sub _goto_level($$$)
{
    my $self  = shift;
    my $level = shift;
    my $name  = shift;

    # _text is multi-line. Check when changing level
    $self->_check_text($self->{section}) or return 0;

    if ($level > $self->{level}) {
        if ($level > $self->{level} + 1) {
            $self->_make_error("section nesting error");
            return 0;
        }
        $self->_next_level($name) or return 0;
    }
    else {

        while ($self->{level} > $level) {
            $self->_prev_level;
        }
        if ($level != 0) {
            $self->_prev_level;
            $self->_next_level($name) or return 0;
        }
    }

    return 1;
}

######### VARIABLES #########

# search grammar definition of a variable
sub _search_variable($$)
{
    my $self = shift;
    my $name = shift;

    if (not defined $self->{grammar}{_vars}) {
        $self->_make_error("no variables are allowed");
        return undef;
    }

    # search exact match
    for (@{$self->{grammar}{_vars}}) {
        if ($name eq $_) {
            return $_;
        }
    }

    # search regular expression
    for (@{$self->{grammar}{_vars}}) {
        if (m|^/(.*)/$|) {
            if ($name =~ /^$1$/) {
                return $_;
            }
        }
    }

    # no match
    $self->_make_error("unknown variable '$name'");
    return undef;
}

sub _set_variable($$$)
{
    my $self  = shift;
    my $key   = shift;
    my $value = shift;

    my $gn = $self->_search_variable($key);
    defined $gn or return 0;

    my $varlistref;
    if (defined $self->{grammar}{_varlist}) {
	$varlistref = $self->{cfg}{_varlist};
    }

    if (defined $self->{grammar}{$gn}) {
        my $g = $self->{grammar}{$gn};

        # check regular expression
        if (defined $g->{_re}) {
            $value =~ /^$g->{_re}$/ or do {
                if (defined $g->{_re_error}) {
                    $self->_make_error($g->{_re_error});
                }
                else {
                    $self->_make_error("syntax error in value of '$key'");
                }
                return 0;
              }
        }
        if (defined $g->{_sub}){
                my $error = &{$g->{_sub}}($value, $varlistref);
                if (defined $error){
                        $self->_make_error($error);
                        return 0;
                }
        }
    }
    $self->{cfg}{$key} = $value;
    push @{$varlistref}, $key if ref $varlistref;

    return 1;
}

######### PARSER #########

sub _parse_table($$)
{
    my $self = shift;
    local $_ = shift;

    my $g = $self->{grammar}{_table};
    defined $g or do {
        $self->_make_error("table syntax error");
        return 0;
    };

    my @l = _quotesplit $_;

    # check number of columns
    my $columns = $g->{_columns};
    if (defined $columns and $#l + 1 != $columns) {
        $self->_make_error("row must have $columns columns (has " . ($#l + 1)
          . ")");
        return 0;
    }

    # check columns
    my $n = 0;
    for my $c (@l) {
        my $gc = $g->{$n};
        defined $gc or next;

        # regular expression
        if (defined $gc->{_re}) {
            $c =~ /^$gc->{_re}$/ or do {
                if (defined $gc->{_re_error}) {
                    $self->_make_error("column ".($n+1).": $gc->{_re_error}");
                }
                else {
                    $self->_make_error("syntax error in column ".($n+1));
                }
                return 0;
            };
        }
        if (defined $gc->{_sub}){
                my $error = &{$gc->{_sub}}($c);
                if (defined $error) {
                        $self->_make_error($error);
                        return 0;
                }
        }
        $n++;
    }

    # hash (keyed table)
    if (defined $g->{_key}) {
        my $kn = $g->{_key};
        if ($kn < 0 or $kn > $#l) {
            $self->_make_error("grammar error: key out of bounds");
        }
        my $k = $l[$kn];

        if (defined $self->{cfg}{$k}) {
            $self->_make_error("table row $k already defined");
            return 0;
        }
        $self->{cfg}{$k} = \@l;
    }

    # list (unkeyed table)
    else {
        push @{$self->{cfg}{_table}}, \@l;
    }

    return 1;
}

sub _parse_text($$)
{
    my ($self, $line) = @_;

    $self->{cfg}{_text} .= $line;

    return 1;
}

sub _check_text($$)
{
    my ($self, $name) = @_;

    my $g = $self->{grammar}{_text};
    defined $g or return 1;

    # chop empty lines at beginning and end
    if(defined $self->{cfg}{_text}) {
	$self->{cfg}{_text} =~ s/\A([ \t]*[\n\r]+)*//m;
	$self->{cfg}{_text} =~  s/^([ \t]*[\n\r]+)*\Z//m;
    }

    if (defined $g->{_re}) {
        $self->{cfg}{_text} =~ /^$g->{_re}$/ or do {
            if (defined $g->{_re_error}) {
                $self->_make_error($g->{_re_error});
            }
            else {
                $self->_make_error("syntax error");
            }
            return 0;
          }
    }
    if (defined $g->{_sub}){
        my $error =  &{$g->{_sub}}($self->{cfg}{_text});
        if (defined $error) {
            $self->_make_error($error);
            return 0;
        }
    }
    return 1;
}

sub _parse_file($$);

sub _parse_line($$$)
{
    my $self = shift;
    local $_ = shift;
    my $source = shift;

    /^\@include\s+["']?(.*)["']?$/ and do {
	my $inc = $1;
        if ( ( $^O eq 'win32' and $inc !~ m|^(?:[a-z]:)?[/\\]|i and  $self->{file} =~ m|^(.+)[\\/][^/]+$| ) or
	     ( $inc !~ m|^/| and $self->{file} =~ m|^(.+)/[^/]+$| ) ){
	   $inc = "$1/$inc";
        }
        push @{$self->{file_stack}}, $self->{file};
        push @{$self->{line_stack}}, $self->{line};
        $self->_parse_file($inc) or return 0;
        $self->{file} = pop @{$self->{file_stack}};
        $self->{line} = pop @{$self->{line_stack}};
        return 1;
    };
    /^\@define\s+(\S+)\s+(.*)$/ and do {
	$self->{defines}{$1}=$2;
	return 1;
    };

    if(defined $self->{defines}) {
	for my $d (keys %{$self->{defines}}) {
	    s/$d/$self->{defines}{$d}/g;
	}
    }

    /^\*\*\*\s*(.*?)\s*\*\*\*$/ and do {
    	my $name = $1;
        $self->_goto_level(1, $name) or return 0;
	$self->_check_section_sub($name) or return 0;
        return 1;
    };
    /^(\++)\s*(.*)$/ and do {
        my $level = length $1;
    	my $name = $2;
        $self->_goto_level($level + 1, $name) or return 0;
	$self->_check_section_sub($name) or return 0;
        return 1;
    };

    if (defined $self->{grammar}{_text}) {
        $self->_parse_text($source) or return 0;
        return 1;
    }
    /^(\S+)\s*=\s*(.*)$/ and do {
        if (defined $self->{cfg}{$1}) {
            if (exists $self->{cfg}{_inherited}{$1}) {
                # it's OK to override any inherited values
                delete $self->{cfg}{_inherited}{$1};
                delete $self->{cfg}{$1};
            } else {
                $self->_make_error('variable already defined');
                return 0;
            }
        }
        $self->_set_variable($1, $2) or return 0;
        return 1;
    };

    $self->_parse_table($_) or return 0;

    return 1;
}

sub _check_section_sub($$) {
	my $self = shift;
	my $name = shift;
	my $g = $self->{grammar};
        if (defined $g->{_sub}){
                my $error = &{$g->{_sub}}($name);
                if (defined $error){
                        $self->_make_error($error);
                        return 0;
                }
        }
	return 1;
}

sub _parse_file($$)
{
    my $self = shift;
    my $file = shift;

    unless ($file) { $self->{'err'} = "no filename given" ;
                     return undef;};

    my $fh;
    my $mode = "<";
    $mode .= ":encoding($self->{encoding})" if $self->{encoding};
    open($fh, $mode, "$file") or do {
        $self->{'err'} = "can't open $file: $!";
        return undef;
    };
    $self->{file} = $file;

    local $_;
    my $source = '';
    while (<$fh>) {
	$source .= $_;
        chomp;
        s/^\s+//;
        s/\s+$//;            # trim
        s/\s*#.*$//;         # comments
        next if $_ eq '';    # empty lines
        while (/\\$/) {# continuation
            s/\\$//;
            my $n = <$fh>;
            last if not defined $n;
            chomp $n;
            $n =~ s/^\s+//;
            $n =~ s/\s+$//;    # trim
            $_ .= ' ' . $n;
        }

        $self->{line} = $.;
        $self->_parse_line($_, $source) or do{ close $fh; return 0; };
	$source = '';
    }
    close $fh;
    return 1;
}

sub makepod($) {
    my $pod = eval {
	require Config::Grammar::Document;
	return Config::Grammar::Document::makepod(@_);
    };
    defined $pod or die "ERROR: install Config::Grammar::Document in order to use makepod(): $@\n";
    return $pod;
}

sub maketmpl ($@) {
    my $pod = eval {
	require Config::Grammar::Document;
	return Config::Grammar::Document::maketmpl(@_);
    };
    defined $pod or die "ERROR: install Config::Grammar::Document in order to use maketmpl()\n";
    return $pod;
}

sub makemintmpl ($@) {
    my $pod = eval {
	require Config::Grammar::Document;
	return Config::Grammar::Document::makemintmpl(@_);
    };
    defined $pod or die "ERROR: install Config::Grammar::Document in order to use makemintmpl()\n";
    return $pod;
}

sub parse($$$)
{
    my $self = shift;
    my $file = shift;
    my $args = shift;

    $self->{encoding} = $args->{encoding} if ref $args eq 'HASH';

    $self->{cfg}           = {};
    $self->{level}         = 0;
    $self->{cfg_stack}     = [];
    $self->{grammar_stack} = [];
    $self->{file_stack}    = [];
    $self->{line_stack}    = [];

    $self->_parse_file($file) or return undef;

    $self->_goto_level(0, undef) or return undef;

    # fill in the top level values from _default keywords
    $self->_fill_defaults;

    $self->_check_mandatory($self->{grammar}, $self->{cfg}, undef)
      or return undef;

    return $self->{cfg};

}

1;

__END__