File Coverage

lib/Config/HAProxy/Node/Section.pm

Criterion	Covered	Total	%
statement	44	78	56.4
branch	7	18	38.8
condition	0	3	0.0
subroutine	10	14	71.4
pod	8	9	88.8
total	69	122	56.5

package Config::HAProxy::Node::Section;
use strict;
use warnings;
use parent 'Config::HAProxy::Node';
use Carp;

=head1 NAME

Config::HAProxy::Node::Section - HAProxy configuration section

=head1 DESCRIPTION

Objects of this class represent a C in the HAProxy configuration file.
A section is a statement that can contain sub-statements. The following
statements form sections: B, B, B, and B.

=cut

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(@_);
    $self->{_tree} = [];
    return $self;
}

=head1 ATTRIBUTES

=head2 is_section

Always true.

=cut

sub is_section { 1 }

=head1 METHODS

=head2 kw

Returns the configuration keyword.

=head2 argv

Returns the list of arguments to the configuration keyword.

=head2 arg

    $s = $node->arg($n)

Returns the B<$n>th argument.

=head2 orig

Returns original line as it appeared in the configuration file.

=head2 locus

Returns the location of this statement in the configuration file (the
B object).

=head2 append_node

    $section->append_node(@nodes);

Takes a list of objects of B derived classes as
arguments. Adds these objects after the last node in the subtree in this
section.

=cut

sub append_node {
    my $self = shift;
    my $n = @{$self->{_tree}};
    push @{$self->{_tree}},
         map {
	     $_->parent($self);
	     $_->index($n++);
	     $_
	 }  @_;
}

=head2 append_node_nonempty

    $section->append_node_nonempty(@nodes);

Same as B, but adds new nodes after the last non-empty
node in the subtree.

=cut

sub append_node_nonempty {
    my $self = shift;
    my $n = $#{$self->{_tree}};
    while ($n >= 0 && $self->{_tree}[$n]->is_empty) {
	$n--;
    }
    $self->insert_node($n+1, @_);
}

=head2 insert_node

    $section->insert_node($idx, @nodes);

Inserts B<@nodes> after subnode in position B<$idx> (0-based).

=cut

sub insert_node {
    my $self = shift;
    my $n = shift;
    my $i = $n;
    splice @{$self->{_tree}}, $n, 0,
         map {
	     $_->parent($self);
	     $_->index($i++);
	     $_
	 }  @_;
    for (; $i < @{$self->{_tree}}; $i++) {
	$self->{_tree}[$i]->index($i);
    }
}

=head2 delete_node

    $section->delete_node($i);

Deletes B<$i>th subnode from the B<$section>.

=cut

sub delete_node {
    my ($self, $n) = @_;
    splice @{$self->{_tree}}, $n, 1;
    for (; $n < @{$self->{_tree}}; $n++) {
	$self->{_tree}[$n]->index($n);
    }
    $self->root->mark_dirty;
}

=head2 tree

    @nodes = $section->tree;

Returns subnodes as a list of B derived objects.

    $node = $section->tree($i);

Returns B<$i>th subnode from the B<$section>.

=cut

sub tree {
    my ($self, $n) = @_;
    if ($n) {
	return undef if $n >= @{$self->{_tree}};
	return $self->{_tree}[$n];
    }
    return @{shift->{_tree}}
};

=head2 ends_in_empty

    $bool = $section->ends_in_empty

Returns true if the last node in the list of sub-nodes in B<$section> is
an empty node.

=cut

sub ends_in_empty {
    my $self = shift;
    while ($self->is_section) {
	$self = $self->tree(-1);
    }
    return $self->is_empty;
}

my %match = (
    name => {
	wantarg => 1,
	matcher => sub {
	    my ($node, $value) = @_;
	    return $node->kw && $node->kw eq $value;
	}
    },
    arg => {
	wantarg => 1,
	matcher => sub {
	    my ($node, $value) = @_;
	    my $arg = $node->arg($value->{n});
	    return $arg && $arg eq $value->{v};
	}
    },
    section => {
	matcher => sub {
	    my $node = shift;
	    return $node->is_section;
	}
    },
    statement => {
	matcher => sub {
	    my $node = shift;
	    return $node->is_statement;
	}
    },
    comment => {
	matcher => sub {
	    my $node = shift;
	    return $node->is_comment;
	}
    }
);

=head2 select

    @nodes = $section->select(%cond);

Returns nodes from B<$section> that match conditions in B<%cond>. Valid
conditions are:

=over 4

=item B> I<$s>

Node matches if its keyword (B) equals I<$s>.

=item B> B<{ n =E> I<$n>, B =E I<$s> B<}>

Node mathches if its I<$n>th argument equals I<$s>.

=item B> I<$bool>

Node matches if it is (or is not, if I<$bool> is false) a section.

=item B> I<$bool>

Node matches if it is (not) a simple statement.

=item B> I<$bool>

Node matches if it is (not) a comment.

=back

Multiple conditions are checked in the order of their appearance in the
argument list and are joined by the short-circuit logical C.

For example, to return all B statements:

  @fe = $section->select(name => 'frontend');

To return the frontend named C:

  ($fe) = $section->select( name => 'frontend',
                            arg => { n => 0, v => 'in' } );

=cut

sub select {
    my $self = shift;
    my @prog;
    while (my $p = shift) {
	my $arg = shift or croak "missing argument";
	my $m = $match{$p} or croak "unknown matcher: $p";
	if ($m->{wantarg}) {
	    push @prog, [ $m->{matcher}, $arg ];
	} elsif ($arg) {
	    push @prog, $m->{matcher};
	}
    }
    grep { _test_node($_, @prog) } $self->tree;
}

sub _test_node {
    my $node = shift;
    foreach my $f (@_) {
	if (ref($f) eq 'ARRAY') {
	    return 0 unless &{$f->[0]}($node, $f->[1]);
	} else {
	    return 0 unless &{$f}($node);
	}
    }
    return 1;
}

=head1 SEE ALSO

B, B, B.

=cut

1;