view release on metacpan or  search on metacpan

lib/AC/ConfigFile/Simple.pm  view on Meta::CPAN

# keyword value
# ...

package AC::ConfigFile::Simple;
use AC::Misc;
use AC::DC::Debug;
use Socket;
use strict;

my $MINSTAT = 15;

my %CONFIG = (
    include	=> \&include_file,
    debug	=> \&parse_debug,
    allow	=> \&parse_allow,
    _default	=> \&parse_keyvalue,
);


sub new {
    my $class = shift;
    my $file  = shift;

    my $me = bless {
	_laststat	=> $^T,
	_lastconf	=> $^T,
        _configfile	=> $file,
        _files		=> [ ],
	@_,
    }, $class;

    $me->_read();
    return $me;
}

sub check {
    my $me = shift;

    my $now = $^T;
    return if $now - $me->{_laststat} < $MINSTAT;
    $me->{_laststat} = $now;

    my $changed;
    for my $file ( @{$me->{_files}} ){
        my $mtime = (stat($file))[9];
        $changed = 1 if $mtime > $me->{_lastconf};
    }
    return unless $changed;

    verbose("config file changed. reloading");
    $me->{_lastconf} = $now;

    eval {
	$me->_read();
        verbose("installed new config file");
        if( my $f = $me->{onreload} ){
            $f->();
        }
    };
    if(my $e = $@){
        problem("error reading new config file: $e");
        return;
    }

    return 1;
}

sub _read {
    my $me = shift;

    delete $me->{_pending};

    $me->_readfile($me->{_configfile});

    $me->{config} = $me->{_pending};
    delete $me->{_pending};
}

sub _readfile {
    my $me   = shift;
    my $file = shift;

    my $fd;
    open($fd, $file) || die "cannot open file '$file': $!";
    $me->{fd} = $fd;

    push @{$me->{_files}}, $file;

    while( defined(my $l = $me->_nextline()) ){
        my($key, $rest) = split /\s+/, $l, 2;
        $me->handle_config( $key, $rest ) || die "invalid config '$key'\n";
    }

    close $fd;
}

sub handle_config {
    my $me   = shift;
    my $key  = shift;
    my $rest = shift;

    my $fnc = $CONFIG{$key} || $CONFIG{_default};
    return unless $fnc;
    $fnc->($me, $key, $rest);
    return 1;
}

sub _nextline {
    my $me = shift;

    my $line;
    while(1){
        my $fd = $me->{fd};

        my $l = <$fd>;
        return $line unless defined $l;
        chomp $l;

        $l =~ s/\#.*$//;
        $l =~ s/^\s*//;
        $l =~ s/\s+$//;