File Coverage

blib/lib/Config/Inetd.pm

Criterion	Covered	Total	%
statement	90	92	97.8
branch	13	16	81.2
condition	3	8	37.5
subroutine	20	20	100.0
pod	7	7	100.0
total	133	143	93.0

package Config::Inetd;

use strict;
use warnings;
use boolean qw(true false);

use Carp qw(croak);
use Fcntl qw(O_RDWR LOCK_EX);
use Params::Validate ':all';
use Tie::File ();

our ($VERSION, $INETD_CONF);

$VERSION = '0.31_01';
$INETD_CONF = '/etc/inetd.conf';

validation_options(
    on_fail => sub
{
    my ($error) = @_;
    chomp $error;
    croak $error;
},
    stack_skip => 2,
);

sub new
{
    my $class = shift;

    my $self = bless {}, ref($class) || $class;

    $self->_tie_conf(@_);
    $self->_parse_enabled;

    return $self;
}

sub _tie_conf
{
    my $self = shift;
    my ($conf_file) = @_;
    $conf_file ||= $INETD_CONF;

    my $conf_tied = tie(
        @{$self->{CONF}}, 'Tie::File', $conf_file,
        mode => O_RDWR, autochomp => false
    ) or croak "Cannot tie `$conf_file': $!";
    $conf_tied->flock(LOCK_EX)
      or croak "Cannot lock `$conf_file': $!";
}

sub _parse_enabled
{
    my $self = shift;

    $self->_filter_conf($self->{CONF});

    foreach my $entry (@{$self->{CONF}}) {
        my ($serv, $prot) = $self->_extract_serv_prot($entry);
        $self->{ENABLED}{$serv}{$prot} = $entry !~ /^\#/
          ? true : false;
    }
}

sub is_enabled
{
    my $self = shift;
    $self->_validate(@_);
    my ($serv, $prot) = @_;

    return exists $self->{ENABLED}{$serv}{$prot}
      ? $self->{ENABLED}{$serv}{$prot}
      : undef;
}

sub enable
{
    my $self = shift;
    $self->_validate(@_);
    my ($serv, $prot) = @_;

    foreach my $entry (@{$self->{CONF}}) {
        if ($entry =~ /^ \# .*? $serv .+? $prot \b/x) {
            $self->{ENABLED}{$serv}{$prot} = true;
            $entry = substr($entry, 1);
            return true;
        }
    }

    return false;
}

sub disable
{
    my $self = shift;
    $self->_validate(@_);
    my ($serv, $prot) = @_;

    foreach my $entry (@{$self->{CONF}}) {
        if ($entry =~ /^ (?!\#) .*? $serv .+? $prot \b/x) {
            $self->{ENABLED}{$serv}{$prot} = false;
            $entry = "#$entry";
            return true;
        }
    }

    return false;
}

sub dump_enabled
{
    my $self = shift;

    my @conf = @{$self->{CONF}};
    $self->_filter_conf(\@conf, qr/^[^\#]/);

    return @conf;
}

sub dump_disabled
{
    my $self = shift;

    my @conf = @{$self->{CONF}};
    $self->_filter_conf(\@conf, qr/^\#/);

    return @conf;
}

sub config
{
    my $self = shift;
    validate_pos(@_);

    return $self->{CONF};
}

sub _filter_conf
{
    my $self = shift;
    my ($conf, @regexps) = @_;

    unshift @regexps, qr/(?:stream|dgram|raw|rdm|seqpacket)/;

    for (my $i = $#$conf; $i >= 0; $i--) {
        foreach my $regexp (@regexps) {
            splice(@$conf, $i, 1) and last
              unless $conf->[$i] =~ $regexp;
        }
    }
}

sub _extract_serv_prot
{
    my $self = shift;
    my ($entry) = @_;

    my ($serv, $prot) = (split /\s+/, $entry)[0,2];

    $serv =~ s/.*:(.*)/$1/;
    $serv = substr($serv, 1) if $serv =~ /^\#/;

    return ($serv, $prot);
}

sub _validate
{
    my $self = shift;
    validate_pos(@_, { type => SCALAR }, { type => SCALAR });
}

DESTROY
{
    my $self = shift;
    untie @{$self->{CONF}};
}

1;
__END__