File Coverage

blib/lib/Config/Savelogs.pm

Criterion	Covered	Total	%
statement	221	234	94.4
branch	67	98	68.3
condition	4	10	40.0
subroutine	23	23	100.0
pod	13	13	100.0
total	328	378	86.7

package Config::Savelogs;

use 5.008001;
use strict;
use warnings;
use Carp 'carp';
use Storable ();

our $VERSION = '0.11';

## note this: savelogs configuration files are UNORDERED. In that
## spirit, we don't preserve ordering of any fields. When we
## pretty-print, we put bare directives first and then groups last.

## class members
my %file    = ();
my %directs = ();
my %dirty   = ();

## other
my %array_type = ( apachelogexclude => [],
                   apachehost       => [],
                   log              => [],
                   nolog            => [], );

my %normal = ( apacheconf       => 'ApacheConf',
               apachehost       => 'ApacheHost',
               logfile          => 'LogFile',
               loglevel         => 'LogLevel',
               size             => 'Size',
               touch            => 'Touch',
               chown            => 'Chown',
               chmod            => 'Chmod',
               period           => 'Period',
               count            => 'Count',
               hourly           => 'Hourly',
               postmovehook     => 'PostMoveHook',
               apachelogexclude => 'ApacheLogExclude',
               apachelog        => 'ApacheLog',
               clobber          => 'Clobber',
               filter           => 'Filter',
               ext              => 'Ext',
               datefmt          => 'DateFmt',
               process          => 'Process',
               archive          => 'Archive',
               nolog            => 'NoLog',
               log              => 'Log',
               disabled         => 'Disabled',
             );

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

    my $self = bless \(my $ref), $class;

    $file    {$self} = '';
    $directs {$self} = {};
    $dirty   {$self} = {};

    if( $file ) {
        $self->file($file);
        $self->read() if -f $file;
    }

    return $self;
}

sub read {
    my $self = shift;
    $self->file(@_)
      or return;

    $directs {$self} = {};  ## reset

    open my $fh, "<", $file{$self}
      or do {
          carp "Couldn't read file '" . $file{$self} . "': $!\n";
          return;
      };

    while( my $line = <$fh> ) {
        chomp $line;
        next unless $line;
        next if $line =~ /^\s*\#/;  ## skip comments

        ## parse a group [ARRAYREF]
        if( $line =~ /^\s*/i ) {
            my $group = $self->_parse_group($fh);
            $directs{$self}->{groups} ||= [];
            push @{ $directs{$self}->{groups} }, $group;
            next;
        }

        my $data = _parse_line($line);

        ## got a {Directive => Value} pair
        if( ref($data) ) {
            my ($directive, $value) = each %$data;
            $directive = lc($directive);   ## normalize

            if( exists $array_type{$directive} ) {
                $directs{$self}->{$directive} ||= [];
                push @{ $directs{$self}->{$directive} }, $value;
            }
            else {
                $directs{$self}->{$directive} = $value;
            }
        }

        next;
    }

    close $fh;

    ## make a deep copy here of %directs
    $dirty{$self} = Storable::dclone($directs{$self});

    return 1;
}

sub set {
    my $self = shift;

    while( @_ ) {
        my $directive = shift;
        my $value     = shift;

        ## overwrite existing data
        $directive = lc($directive);  ## normalize
        if( exists $array_type{$directive} ) {
            $directs{$self}->{$directive} = [ $value ];
        }
        else {
            $directs{$self}->{$directive} = $value;
        }
    }
}

sub add_group {
    my $self = shift;
    my %args = @_;
    push @{ $directs{$self}->{groups} }, $self->_fix_group(\%args);
}

sub _fix_group {
    my $self = shift;
    my $group = shift;

    for my $key ( %$group ) {
        next unless exists $array_type{lc($key)};
        next if ref($group->{$key});
        $group->{$key} = [ $group->{$key} ];
    }

    return $group;
}

sub remove_group {
    my $self = shift;
    my %args = @_;

    my $match = delete $args{match}
      or return;

    my @removed = ();

    ## find first matching group
    my $groups = $directs{$self}->{groups};
  GROUP: for my $i ( 0..$#$groups ) {
        my $group = $groups->[$i];

      MATCH: for my $mkey ( keys %$match ) {
            my $gkey = lc($mkey);
            next GROUP unless exists $group->{$gkey};
            if( ref($group->{$gkey}) ) {
                for my $value (@{ $group->{$gkey} }) {
                    last MATCH if $value eq $match->{$mkey};
                }
                next GROUP;
            }
            else {
                next GROUP unless $group->{$gkey} eq $match->{$mkey};
            }
        }

        push @removed, $groups->[$i];
        $groups->[$i] = undef;
    }

    @$groups = grep { defined } @$groups;

    return @removed;
}

sub find_group {
    my $self = shift;
    my %args = @_;

    my $match = delete $args{match}
      or return;

    my $groups = $directs{$self}->{groups};
    my $find_group;
  GROUP: for my $group ( @$groups ) {
      MATCH: for my $mkey ( keys %$match ) {
            my $gkey = lc($mkey);  ## normalize
            next GROUP unless exists $group->{$gkey};

          DO_MATCH: {
                if( ref($group->{$gkey}) ) {
                    for my $value ( @{ $group->{$gkey} } ) {
                        last DO_MATCH if $value eq $match->{$mkey};
                    }
                    next GROUP;
                }
                else {
                    next GROUP unless $group->{$gkey} eq $match->{$mkey};
                }
            }

            $find_group = $group;
            last GROUP;
        }
    }

    return $find_group;
}

## FIXME: make work with Log or other multiple directives
sub add_to_group {
    my $self = shift;
    my %args = @_;

    my $match = delete $args{match}
      or return;

    my $host = delete $args{apachehost};
    unless( ref($host) ) {
        $host = [ $host ];
    }

    my $found;
    if( my $group = $self->find_group(match => $match) ) {
        my $hosts = $group->{apachehost};
        $group->{apachehost} = [ sort (@$hosts, @$host) ];
        $found = 1;
    }

    return $found;
}

## FIXME: make work with Log or other multiple directives
sub remove_from_group {
    my $self = shift;
    my %args = @_;

    my $match = delete $args{match}
      or return;

    my $host = delete $args{apachehost};
    unless( ref($host) ) {
        $host = [ $host ];
    }

    my %host = ();
    @host{@$host} = (1) x @$host;

    if( my $group = $self->find_group(match => $match) ) {
        my $hosts = $group->{apachehost};
        $group->{apachehost} = [ sort grep { ! $host{$_} } @$hosts ];
    }

    return 1;
}

sub data {
    my $self = shift;
    my $groups = $directs{$self}->{groups};
    my $changed = 0;

  GROUPS: for my $group ( @$groups ) {
        my $valid_group = 0;
        for my $key ( sort keys %$group ) {
            my $val  = $group->{$key};
            next unless ref($val);

            for my $lval ( @$val ) {
                $valid_group = 1 if lc($key) eq 'apachehost' or lc($key) eq 'log';
                next GROUPS if $valid_group;
            }

            ## we have an invalid group here
            undef $group;
            $changed = 1;
            next GROUPS;
        }
    }

    if( $changed ) {
        @$groups = grep { defined $_ } @$groups;
        $directs{$self}->{groups} = $groups;
    }

    return $directs{$self};
}

sub file {
    my $self = shift;

    if( @_ ) {
        $file{$self} = shift;
    }

    return $file{$self};
}

sub is_dirty {
    my $self = shift;

    local $Storable::canonical = 1;

    my $cmp1 = Storable::freeze($directs{$self});
    my $cmp2 = Storable::freeze($dirty{$self});

    return $cmp1 ne $cmp2;
}

sub revert {
    my $self = shift;
    $directs{$self} = Storable::dclone($dirty{$self});
}

sub write {
    my $self = shift;
    $self->file(@_)
      or return;

    open my $fh, ">", $file{$self}
      or do {
          carp "Couldn't write file '" . $file{$self} . "': $!\n";
          return;
      };

    my %config = %{ $self->data };
    my $groups = delete $config{groups};

    for my $key ( keys %config ) {
        my $directive = ($normal{$key} ? $normal{$key} : $key);

        if( ref($config{$key}) ) {
            for my $value ( @{$config{$key}} ) {
                print $fh "$directive\t$value\n";
            }
        }
        else {
            print $fh "$directive\t$config{$key}\n";
        }
    }

    _write_groups($fh, $groups) if $groups;

    close $fh;

    $dirty{$self} = Storable::dclone($directs{$self});

    return 1;
}

sub _write_groups {
    my $fh     = shift;
    my $groups = shift;
    my $str    = '';

    ## FIXME: sort by apachehost, then log directive
  GROUP: for my $group ( @$groups ) {
        my $tstr .= "\n";
        $tstr .= "\n";
        for my $key ( sort keys %$group ) {
            my $val = $group->{$key};
            my $tab = ( length($key) > 5 ? "\t" : "\t\t" );
            my $nkey = $normal{lc($key)} || $key;

            if( ref($val) ) {
                for my $lval ( @$val ) {
                    $tstr .= "  $nkey${tab}$lval\n";
                }
            }
            else {
                $tstr .= "  $nkey${tab}$val\n";
            }
        }
        $tstr .= "\n";

        $str .= $tstr;
    }

    print $fh $str if $str;

    return 1;
}

sub _parse_line {
    my $line = shift;

    if( my($directive, $value) = $line =~ /^\s*(\S+)\s*(.*)/ ) {
        $value =~ s/\s*$//;
        return { $directive => $value };
    }

    return $line;  ## something we don't recognize
}

sub _parse_group {
    my $self  = shift;
    my $fh    = shift;
    my %group = ();

    while( my $line = <$fh> ) {
        chomp $line;
        next unless $line;
        next if $line =~ /^\s*\#/;  ## skip comments

        if( $line =~ m{\s*}i ) {
            last;
        }

        my $data = _parse_line($line);
        if( ref($data) ) {
            my($key, $val) = each %$data;
            $key = lc($key);   ## normalize

            if( exists $array_type{$key} ) {
                $group{$key} = []
                  unless exists $group{$key};
                push @{$group{$key}}, $val;
            }

            ## overwrite previous entry if multiple
            else {
                $group{$key} = $val;
            }
        }
    }

    return \%group;
}

sub DESTROY {
    my $self = $_[0];

    delete $file    {$self};
    delete $directs {$self};

    my $super = $self->can("SUPER::DESTROY");
    goto &$super if $super;
}

1;
__END__