File Coverage

lib/Config/HAProxy.pm

Criterion	Covered	Total	%
statement	147	196	75.0
branch	35	74	47.3
condition	3	7	42.8
subroutine	29	34	85.2
pod	10	17	58.8
total	224	328	68.2

package Config::HAProxy;
use 5.010;
use strict;
use warnings;
use Text::Locus;
use Config::HAProxy::Node::Root;
use Config::HAProxy::Node::Section;
use Config::HAProxy::Node::Statement;
use Config::HAProxy::Node::Comment;
use Config::HAProxy::Node::Empty;
use Text::ParseWords;
use File::Basename;
use File::Temp qw(tempfile);
use File::stat;
use File::Spec;
use IPC::Cmd qw(run);
use Carp;

our $VERSION = '1.08';

my %sections = (
    global => 1,
    defaults => 1,
    frontend => 1,
    backend => 1,
    resolvers => 1
);

sub new {
    my $class = shift;
    my $filename = shift // '/etc/haproxy/haproxy.cfg';
    my $self = bless { _filename => $filename,
		       _lint => { enable => 1 } }, $class;
    $self->reset();
    return $self;
}

sub filename { shift->{_filename} }

sub parse {
    my $self = shift;

    open(my $fh, '<', $self->filename)
	or croak "can't open ".$self->filename.": $!";
    my $line = 0;
    $self->reset();
    $self->push($self->tos);
    while (<$fh>) {
	my $locus = new Text::Locus($self->filename, ++$line);
	chomp;
	my $orig = $_;
	s/^\s+//;
	s/\s+$//;

	if ($_ eq "") {
	    $self->tos->append_node(
		new Config::HAProxy::Node::Empty(locus => $locus));
	    next;
	}

	if (/^#.*/) {
	    $self->tos->append_node(
		new Config::HAProxy::Node::Comment(orig => $orig,
						   locus => $locus));
	    next;
	}

	my @words = parse_line('\s+', 1, $_);
	my $kw = shift @words;
	if ($sections{$kw}) {
	    my $section =
		new Config::HAProxy::Node::Section(kw => $kw,
						   argv => \@words,
						   orig => $orig,
						   locus => $locus);
	    $self->pop;
	    $self->tos->append_node($section);
	    $self->push($section);
	} else {
	    $self->tos->append_node(
		new Config::HAProxy::Node::Statement(kw => $kw,
						     argv => \@words,
						     orig => $orig,
						     locus => $locus));
	}
    }
    $self->pop;
    close $fh;
    return $self;
}

sub declare_section {
    my ($class, $name) = @_;
    $sections{$name} = 1;
}

sub undeclare_section {
    my ($class, $name) = @_;
    $sections{$name} = 0;
}

sub reset {
    my $self = shift;
    $self->{_stack} = [ new Config::HAProxy::Node::Root() ];
}

sub push {
    my $self = shift;
    push @{$self->{_stack}}, @_;
}

sub pop {
    my $self = shift;
    croak "can't pop the root tree" if @{$self->{_stack}} == 1;
    pop @{$self->{_stack}};
}

sub tos {
    my $self = shift;
    $self->{_stack}[-1];
}

sub tree {
    my $self = shift;
    $self->{_stack}[0];
}

sub select {
    my $self = shift;
    $self->tree->select(@_);
}

sub iterator {
    my $self = shift;
    $self->tree->iterator(@_);
}

sub write {
    my $self = shift;
    my $file = shift;
    my $fh;

    if (ref($file) eq 'GLOB') {
	$fh = $file;
    } else {
	open($fh, '>', $file) or croak "can't open $file: $!";
    }

    local %_ = @_;
    my $itr = $self->iterator(inorder => 1);

    while (defined(my $node = $itr->next)) {
	my $s = $node->as_string;
	if ($_{indent}) {
	    if ($node->is_comment) {
		if ($_{reindent_comments}) {
		    my $indent = ' ' x ($_{indent} * $node->depth);
		    $s =~ s/^\s+//;
		    $s = $indent . $s;
		}
	    } else {
		my $indent = ' ' x ($_{indent} * $node->depth);
		if ($_{tabstop}) {
		    $s = $indent . $node->kw;
		    for (my $i = 0; my $arg = $node->arg($i); $i++) {
			my $off = 1;
			if ($i < @{$_{tabstop}}) {
			    if (($off = $_{tabstop}[$i] - length($s)) <= 0) {
				$off = 1;
			    }
			}
			$s .= (' ' x $off) . $arg;
		    }
		} else {
		    $s =~ s/^\s+//;
		    $s = $indent . $s;
		}
	    }
	}
	print $fh $s,"\n";
    }

    close $fh unless ref($file) eq 'GLOB';
}

sub lint {
    my $self = shift;

    if (@_) {
	if (@_ == 1) {
	    $self->{_lint}{enable} = !!shift;
	} elsif (@_ % 2 == 0) {
	    local %_ = @_;
	    my $v;
	    if (defined($v = delete $_{enable})) {
		$self->{_lint}{enable} = $v;
	    }
	    if (defined($v = delete $_{command})) {
		$self->{_lint}{command} = $v;
	    }
	    if (defined($v = delete $_{path})) {
		$self->{_lint}{path} = $v;
	    }
	    croak "unrecognized keywords" if keys %_;
	} else {
	    croak "bad number of arguments";
	}
    }

    if ($self->{_lint}{enable}) {
	$self->{_lint}{command} ||= 'haproxy -c -f';
	if ($self->{_lint}{path}) {
	    my ($prog, $args) = split /\s+/, $self->{_lint}{command}, 2;
	    if (!File::Spec->file_name_is_absolute($prog)) {
		foreach my $dir (split /:/, $self->{_lint}{path}) {
		    my $name = File::Spec->catfile($dir, $prog);
		    if (-x $name) {
			$prog = $name;
			last;
		    }
		}
		if ($args) {
		    $prog .= ' '.$args;
		}
		$self->{_lint}{command} = $prog;
	    }
	}
	return $self->{_lint}{command};
    }
}

sub save {
    my $self = shift;
    croak "bad number of arguments" if @_ % 2;
    local %_ = @_;
    my $dry_run = delete $_{dry_run};
    my @wrargs = %_;

    return unless $self->tree;# FIXME
    return unless $self->tree->is_dirty;
    my ($fh, $tempfile) = tempfile('haproxy.XXXXXX',
				   DIR => dirname($self->filename));
    $self->write($fh, @wrargs);
    close($fh);
    if (my $cmd = $self->lint) {
	my ($ok, $err, $full, $outbuf, $errbuf) =
	    run(command => "$cmd $tempfile");
	unless ($ok) {
	    unlink $tempfile;
	    if ($errbuf && @$errbuf) {
		croak "Syntax check failed: ".join("\n", @$errbuf)."\n";
	    }
	    croak $err;
	}
    }
    return 1 if $dry_run;

    my $sb = stat($self->filename);
    $self->backup;
    rename($tempfile, $self->filename)
	or croak "can't rename $tempfile to ".$self->tempfile.": $!";
    # This will succeed: we've created the file, so we're owning it.
    chmod $sb->mode & 0777, $self->filename;
    # This will fail unless we are root, let it be so.
    chown $sb->uid, $sb->gid, $self->filename;

    $self->tree->clear_dirty;
    return 1;
}

sub backup_name {
    my $self = shift;
    $self->filename . '~'
}

sub backup {
    my $self = shift;
    my $backup = $self->backup_name;
    if (-f $backup) {
	unlink $backup
	    or croak "can't unlink $backup: $!"
    }
    rename $self->filename, $self->backup_name
	or croak "can't rename :"
	         . $self->filename
		 . " to "
		 . $self->backup_name
		 . ": $!";
}

1;
__END__